makro ile excel listesinde bulunan aynı autocad dosyalarını açmak

[selimkızılaslan]

Arkadaşlar merhaba
Makroda çok yeniyim
Ancak bir sorum var.
Belirli bir klasör ve alt dizinlerinde autocad dosyalarım var. Birde excel listem. Bu excel listesinde dosya adları yazılı. listede bulunan herhangi bir hücredeki dosyayı üzerine geldiğimde çalıştıracağım makro ile bu autocad dosyanın açılmasını istiyorum

Örneğin
dosyanın adı "INA-E01-02-00-00-0-SD-DWG-STR-00-9000-008" böyle bir şey. Uzantısı ise ".dwg"
şimdiden teşekkür ederim

 

[PLİNT]

Merhaba
Dosya adlarının "A" sütununda ve "Autocad" dosyalarının "D:\" diskinde olduğunu varsayarak; aşağıdaki ".pdf" dosyası için olan örnek kodda ki ikinci kırmızı bölümü ("Autocad.exe") programın yüklü olduğu adresi; diğerlerinde uzantıyı düzeltin.
Kodları dosya adlarının bulunduğu sayfanın VBA penceresine yapıştırın ad yazan
("A" sütununda) hücreyi seçtiğinizde arayıp açacaktır.
Dosyaların bulunduğu alt klasörler, belli bir klasör içinde ise "D:\" yerine
""D:\DOSYALAR\" gibi yazıp arama süresini kısaltabilirsiniz
Örnek dosya eklerseniz www.dosya.tc

[SIZE="2"]Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column <> 1 Or Target.Value = "" Then Exit Sub
Set a = CreateObject("scripting.filesystemobject")
Set dic = CreateObject("scripting.dictionary")
dic.CompareMode = vbBinaryCompare
n = 1
dic.Add n, [COLOR="Blue"]"D:\"[/COLOR]
geri:
h = dic.Count
On Error Resume Next
For j = n To h
Set klasor = a.GetFolder(dic(j))
 If klasor.Subfolders.Count > 0 Then
For Each alt In klasor.Subfolders
dic.Add dic.Count + 1, alt
If a.FileExists(alt & "\" & Target.Value & "[COLOR="Red"].pdf[/COLOR]") = True Then
Shell [COLOR="Red"]"C:\Program Files\Adobe\Reader 11.0\Reader\AcroRd32.exe" [/COLOR]& " " & alt & _
 "\" & Target.Value & "[COLOR="Red"].pdf[/COLOR]"""
Set dic = Nothing
Exit Sub
End If
Next: End If: Next
If h < dic.Count Then
n = h + 1: Set klasor = Nothing:
GoTo geri: End If
End Sub[/SIZE]

 

[selimkızılaslan]

Merhaba ilginiz için teşekkür ederim
bahsettiğiniz düzeltmeleri yaptım.

Ancak makro, makro çalıştırma listesinde görülmedi...
Daha yolun başındayım sanırım... Bu amaçla forumları taradım.. Private Sub Worksheet_SelectionChange(ByVal Target As Range) ifadesi sayfa makrosu olduğunu anladım selection chane ise yanlış anlamadıysam herhangi bir hücre değişikliği yaparsam makro aktif oluyormuş.

Neyse ben başına Public sub mymacro() yazdım

Ancak 2 satırde durdu
If Target.Column <> 1 Or Target.Value = "" Then

Oysa aradığım hücre A sutununda idi...




Dosyayı yükledim .. ayrıca örnek bir çizimide ekledim..


http://s7.dosya.tc/server3/0i4xyx/proje_lstesi_makro.rar.html

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column <> 1 Or Target.Value = "" Then Exit Sub
Set a = CreateObject("scripting.filesystemobject")
Set dic = CreateObject("scripting.dictionary")
dic.CompareMode = vbBinaryCompare
n = 1
dic.Add n, "C:\DWG\EN"
geri:
h = dic.Count
On Error Resume Next
For j = n To h
Set klasor = a.GetFolder(dic(j))
If klasor.Subfolders.Count > 0 Then
For Each alt In klasor.Subfolders
dic.Add dic.Count + 1, alt
If a.FileExists(alt & "\" & Target.Value & ".dwg") = True Then
Shell "C:\Program Files\Autodesk\AutoCAD LT 2018\acadlt.exe" & " " & alt & _
"\" & Target.Value & ".dwg"""
Set dic = Nothing
Exit Sub
End If
Next: End If: Next
If h < dic.Count Then
n = h + 1: Set klasor = Nothing:
GoTo geri: End If
End Sub

 

[PLİNT]

Merhaba
Kodlar hücre seçimine bağlı çalışacağından ek dosyadaki gibi "Sayfa1" e ait kod sayfasında olsun

http://s7.dosya.tc/server3/pfo9ih/proje_lstesi_makro_2.zip.html
NOT: Bütün dosyalar sadece "C:\DWG\EN" klasörü içerisindeyse kısa bir kod yeterli olacaktır mesajınızda alt klasör dediğiniz için kodlar arama yapabilmesi için uzun oldu

 

[selimkızılaslan]

Merhaba
Dosyalar alt klasörlerde olacak ben sadece örnek olsun diye bir adet gönderdim.

Ancak makroyu private sub ile istediğim gibi çalıştıramadım . Kolonu tıkladığımda yada iki hücreyi taradığımda makro çalışıyor
Listedeki sadece bulunduğum hücrede iken makroyu çalıştırıp dosyayı bulup açmasını istemiştim.

Ancak, kolonu yada iki hücreyi tarayarak çalıştığımda da 2. satırda run time hata mesajı veriyor..

 

[PLİNT]

Listedeki sadece bulunduğum hücrede iken makroyu çalıştırıp dosyayı bulup açmasını istemiştim.

Merhaba
Aşağıdaki gibi bir makro adı altına alıp bir "Modül" e ekleyin, "Target" yerine "activecell" kullanabilirsiniz

[SIZE="2"][COLOR="blue"]Sub dosya_ac()[/COLOR]
[COLOR="blue"]If ActiveCell.Value = "" Then Exit Sub[/COLOR]
Set a = CreateObject("scripting.filesystemobject")
Set dic = CreateObject("scripting.dictionary")
dic.CompareMode = vbBinaryCompare
n = 1

If a.FolderExists("C:\DWG") = False Then MsgBox "DWG Klasörü bulunamadı": Exit Sub
[COLOR="Red"]dic.Add n, "C:\DWG\"[/COLOR]

geri:
h = dic.Count
On Error Resume Next
For j = n To h
Set klasor = a.GetFolder(dic(j))
 If klasor.Subfolders.Count > 0 Then
For Each alt In klasor.Subfolders
dic.Add dic.Count + 1, alt

If a.FileExists(alt & "\" & [COLOR="Blue"]ActiveCell[/COLOR].Value & ".dwg") = True Then
Shell "C:\Program Files\Autodesk\AutoCAD LT 2018\acadlt.exe" & " " & alt & _
 "\" & [COLOR="blue"]ActiveCell[/COLOR].Value & ".dwg"""

Set dic = Nothing
Exit Sub
End If
Next: End If: Next
If h < dic.Count Then
n = h + 1: Set klasor = Nothing:
GoTo geri: End If
End Sub[/SIZE]

 

[selimkızılaslan]

Merhaba
Çalıştı ancan dosyayı bulamadı
16 satırdan 2. satıra atladı...?

 

[PLİNT]

Klasörü direkt belirtince başka klasör arıyor olabilir.

dic.Add n, "C:\DWG\EN"

yerine "EN" klasörü adını kaldırıp
Yukarıdaki değişen gibi kullanın

dic.Add n, "C:\DWG\"

"DWG" klasörü içerisinde alt klasörler haricinde ".dwg" dosyasıda oluyorsa kodlardaki ilgili aralığa

[SIZE="2"]
Sub dosya_ac()
If ActiveCell.Value = "" Then Exit Sub
Set a = CreateObject("scripting.filesystemobject")
Set dic = CreateObject("scripting.dictionary")
dic.CompareMode = vbBinaryCompare
n = 1
'________________________________________________
If a.FolderExists("C:\DWG") = False Then MsgBox "DWG Klasörü bulunamadı": Exit Sub
dic.Add n, "C:\DWG\"
[COLOR="Blue"]If a.FileExists("C:\DWG\" & ActiveCell.Value & ".dwg") = True Then
Shell "C:\Program Files\Autodesk\AutoCAD LT 2018\acadlt.exe" & " " & "C:\DWG" & _
 "\" & ActiveCell.Value & ".dwg"""
 Exit Sub
 End If[/COLOR]
geri:
h = dic.Count
On Error Resume Next
For j = n To h
Set klasor = a.GetFolder(dic(j))
 If klasor.Subfolders.Count > 0 Then
For Each alt In klasor.Subfolders
dic.Add dic.Count + 1, alt
'_________________________________________________________________________
If a.FileExists(alt & "\" & ActiveCell.Value & ".dwg") = True Then
Shell "C:\Program Files\Autodesk\AutoCAD LT 2018\acadlt.exe" & " " & alt & _
 "\" & ActiveCell.Value & ".dwg"""
'_________________________________________________________________
Set dic = Nothing
Exit Sub
End If
Next: End If: Next
If h < dic.Count Then
n = h + 1: Set klasor = Nothing:
GoTo geri: End If
End Sub


[/SIZE]

 

[selimkızılaslan]

Çok teşekkür ederim çalıştı

 

[PLİNT]

Çok teşekkür ederim çalıştı

Rica ederim, son şekli bir önceki mesajmdaki kodlar.