değişik uzantılı dosya açma

[pylor]

selamlar D:\D-Belgeler\Epikriz klasörünün içinde birçok alt klasör ve alt klasörlerin içindede çok sayıda değişik uzantıya sahip (doc,xls,rtf,pdf) dosya mevcut ben klasörlerin içindeki dosyaların isimlerini bir excel sayfasında E sütununda alt alta sıraladım sizden istediğim isim listesinde açmak istediğim isme çift tıkladığımda klasörler içinden bu dosyayı bulup açmasıdır böyle bir şey yapılabilirmi acaba

 

[pylor]

değerli uzman arkadaşlar dosyama dair bir çözümü olan varmı acaba

 

[halit3]

Bunu denermisiniz.

CreateObject("Shell.Application").Open ("dosyanın adresi buraya yazılacak")

 

[pylor]

sayın halit3 sanırım anlatımda bir eksikliğim oldu ekte bir dosyam var incelerseniz memnun olurum

 

[halit3]

Sayfaya ait kod

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("e:e")) Is Nothing Then Exit Sub
klasor = "D:\D-Belgeler\Epikriz\"
If Target.Row > 1 Then
If Target.Row <= Cells(Rows.Count, "B").End(3).Row Then
dosya = Cells(Target.Row, "e").Value
If dosya <> "" Then
CreateObject("Shell.Application").Open (klasor & dosya)
End If
End If
End If
End Sub

madüle ait kod

Sub dosyaac()
klasor = "D:\D-Belgeler\Epikriz\"
sat = ActiveWindow.Selection.Row
sut = ActiveWindow.Selection.Column
If Val(sut) = 5 Then
If Val(sat) > 0 Then
dosya = Cells(sat, "e").Value
If dosya <> "" Then
CreateObject("Shell.Application").Open (klasor & dosya)
End If
End If
End If
End Sub

Burasıda sayfanın kod bölümüne farklı bir uygulama

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("e:e")) Is Nothing Then Exit Sub
Klasor = "D:\D-Belgeler\Epikriz\"
If Target.Row > 1 Then
If Target.Row <= Cells(Rows.Count, "B").End(3).Row Then
For Each dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files
yer = Cells(Target.Row, "e").Value
If UCase(Mid(dosya.Name, 1, Len(yer))) = UCase(yer) Then
CreateObject("Shell.Application").Open (Klasor & Dir(dosya))
End If
Next
End If
End If
End Sub

 

[pylor]

sayın halit 3 sizi uğraştırdığımın farkındayım ama gönderdiğiniz kodlar ile yapmak istediğim şeyi yapamadım bu kodları nasıl kullanmam gerektiğini gösteren bir çalışma yapabilirmisiniz. yada benim elimde formda yaptığım aramalar sonunda bulduğum ve tamda yapmak istediğim işi yapan bir dosya var. dosya belirtilen yoldaki xls uzantılı dosyaları açıyor kodlar üzerinde değişiklik yapıp kendime uyarlayıp rtf ve doc uzantılı dosyaları açmaya çalıştım ama başaramadım dosyanın kod sayfasında birçok kod ve klas modüller var ben bu kodlardan bir anlam çıkartamadım sizden rica etsem bu kodlar üzerinde nereleri düzeltmem gerektiğini belirtebilirmisiniz yada siz gereken yerleri düzeltebilirmisiniz böyle bir şey yaparsanız minnettar kalırım teşekkürler

 

[halit3]

6. nolu mesajdaki dosya ile 4 nolu mesajdaki dosya bilgileri farklı

4 nolu mesaşdaki dosyada birinci satırda başlık var yazmış olduğum kod 1 satırı pas geçer ve e sutünundaki enson dolu satıra kadar faliyet gösterir ve e sutunundaki hücrenin dolu olması gerekir

6 nolu mesejınızdaki dosya da veri e1 hücresinde kod 1 satırda çalışmaz

alıntı imzamı okuyunuz örnek dosyalarınızı o doğrultuda düzenleyiniz.

bir nolu mesajda klasörün yolunu "D:\D-Belgeler\Epikriz\" bu olarak belrtmişsiniz.6 nolu mesajda ise "D:\D-belgeler\" bu olarak belirtmişsiniz bunlara dikkat edin kod çalışmaz sonra

 

[halit3]

Buda 6 nolu mesajınızdaki dosya klasör yolunu değiştirdim bu dosyanın yanındaki e sutününda dosya adı yazan dosyaları açar.

 

[pylor]

sayın halit 3 bu konudaki hatamdan dolayı sizden özür dilerim kusuruma bakmayın dosyayı denedim çalışıyor ama sadece bulunduğu klasör içinde arama yapıyor alt klasörlerde arama yapmıyor bu konuda bir öneriniz vamı acaba

 

[halit3]

Ekli dosyanızı kontrol ediniz.

 

[leumruk]

Merhaba,
Halit Bey'e katkılarından dolayı teşekkür ederiz. Bu konuda ben de bir çalışma yaptım. Alternatif olarak deneyebilirsiniz. Uzantıları kırmızı ile belirttiğim yere girin. Dosya yolunuzu da mavi ile belirttiğim kısma...

Hazırladığım kodu Alt klasör listeleme biçimine getirip, ayrı bir başlıkta paylaşıma sunacağım.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("a:a")) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub
Cancel = True
Set ds = CreateObject("Scripting.FileSystemObject")
[COLOR="Navy"]yol = ThisWorkbook.Path[/COLOR]
Do
If ds.GetFolder(yol).subfolders.Count > 0 Then
    For Each kls In ds.GetFolder(yol).subfolders
        klslst = klslst & "{" & kls
    Next
End If
x = x + 1
deg = Split(klslst, "{")
yol = deg(x)
[COLOR="DarkRed"]uzanti = Array(".pdf", ".doc", ".docx", ".rtf", ".xls")[/COLOR]
For q = 0 To UBound(uzanti)
If ds.FileExists(yol & "\" & Target & uzanti(q)) = True Then
    CreateObject("Shell.Application").Open yol & "\" & Target & uzanti(q)
    Exit Sub
End If
Next
Loop While UBound(deg) <> x
End Sub

 

[pylor]

sayın leumruk ilginizden dolayı teşekkür edrim gönderdiğiniz kodları kullandım dediğiniz gibi mavi olan yeri (yol = d:\d-belgeler\epikriz) olarak değiştirdim uzantı kısmına dokunmadım ancak listedeki isimlerden birine tıkladığım zaman
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) sarıya, yol = d:\d-belgeler\epikriz ise kırmızıya boyandı ve kompile eror diye hata verdi
yine ben yanlış yaptım galiba. sayın leumruk benim sizden bir isteğim olucak evvelce yine formun değerli uzmanlarından birisinin yardımı ile böyle bir dosya edinmiştim ama bu dosya sadece xls uzantılı dosyaları açıyordu halen ben bu dosyayı kullanıyorum ancak hastalara ait epikriz dosyalarını rtf yada doc uzantılı kayıt etme zorunluluğu getirildiği için yakın tarih itibarı ile dosyaları belirtilen yoldaki klasörlerin içine doc yada rtf uzantıları ile kayıt ediyorum bu dosyayı düzenlemeye çalıştım ancak başarılı olamadım sizden ricam bu kodlara bir göz atıp burada bir düzenleme yapsanız ben bu dosyamı hiç bozmadan aynen devam etsem nasıl olur olmaz derseniz sizin kodlarlada çalışabilirim ama dediğim gibi kodlar hata verdi

 

[leumruk]

Merhaba,
Girdiğiniz adresi tırnak içine almalısınız. Aşağıdaki şekilde deneyin:

yol = "d:\d-belgeler\epikriz"

 

[pylor]

sayın leumruk dediğiniz gibi yaptım fakat yinede bir başarı sağlayamadım bu konuda başka bir öneri yada çalışmanız olabilirmi acaba

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("a:a")) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub
Cancel = True
Set ds = CreateObject("Scripting.FileSystemObject")
yol = "d:\d-belgeler\epikriz"
Do
If ds.GetFolder(yol).subfolders.Count > 0 Then
For Each kls In ds.GetFolder(yol).subfolders
klslst = klslst & "{" & kls
Next
End If
x = x + 1
deg = Split(klslst, "{")
yol = deg(x)
uzanti = Array(".pdf", ".doc", ".docx", ".rtf", ".xls")
For q = 0 To UBound(uzanti)
If ds.FileExists(yol & "\" & Target & uzanti(q)) = True Then
CreateObject("Shell.Application").Open yol & "\" & Target & ".doc"
Exit Sub
End If
Next
Loop While UBound(deg) <> x
End Sub

kodları bu şekilde düzenledim ama dediğim gibi olmadı

 

[halit3]

10 nolu mesajdaki dosya işinizi görmedimi,?
Genelde aynı olmakla beraber dosyanıza son kez işlem yapıp ekliyorum.
E sutünundaki hücrelere çift tıklayınca bütün uzantılı dosyaları açıyor.

 

[leumruk]

sayın leumruk dediğiniz gibi yaptım fakat yinede bir başarı sağlayamadım bu konuda başka bir öneri yada çalışmanız olabilirmi acaba
kodları bu şekilde düzenledim ama dediğim gibi olmadı

Eklediğim kodları örnek dosyanıza kopyalayıp buraya ekler misiniz? Bir de ben deneyeyim.

 

[pylor]

sayın leumruk biraz uğraşıp çabaladıktan sonra birşeyler ortaya koydum olay şöyle gelişti d içine d-belgeler adında yeni bir klasör ve klasör içine bir excel dosyası açtım kodlarınızı burada uyguladım kodlarınız çalıştı ancak sadece doc uzantılı dosyaları açabildim rtf uzantısınıda açabilsem süper olacak ama illada tek bir uzantı açacaksam rtf uzantısını tecih ederim ekte dosyam mevcuttur teşekkürler. ayrıca sayın halit3 beyefendiye uğraşlarından ve benim için harcadığı emeğinden dolayı teşekkür ederim nezaket ve tevazu gösterdi sabırla verdiği cevapları ve gönderdiği kodları verimli kullanamadığım içinde özrü bir borç bildim sayın leumruk ve sayın halit3 ikinizede teşekkür ederim iyi akşamlar cevabı sabırsızlıkla bekliyorum

 

[leumruk]

Merhaba,
Uzantıyı "uzanti" adıyla tanımlamışım, ama ilgili satıra eklemeyi unutmuşum. Kırmızı alan düzelttiğim kısım. Kodu bu şekliyle eklediğinizde sorun kalmayacaktır. 11 nolu mesajdaki kodu da güncelledim. İhtiyacınız olmayan uzantıları ilgili satırdan silebilirsiniz veya yeni uzantılar ekleyebilirsiniz.

Bu kodun dışında 2. bir alternatif daha ekliyorum. 2. eklediğim kod uzantısı ne olursa olsun hücrede yazan addaki tüm dosyaları açar. 2. eklediğim 1.'ye göre daha hızlı çalışacaktır. Benim önerim 2.'yi kullanmanız. Eğer hücrede yazan dosya sayınız 1 ise "CreateObject("Shell.Application").Open yol & "\" & dosya" komutundan sonra Exit Sub ekleyerek işlemi daha da hızlandırabilirsiniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("a:a")) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub
Cancel = True
Set ds = CreateObject("Scripting.FileSystemObject")
yol = "d:\d-belgeler\epikriz"
Do
If ds.GetFolder(yol).subfolders.Count > 0 Then
    For Each kls In ds.GetFolder(yol).subfolders
        klslst = klslst & "{" & kls
    Next
End If
x = x + 1
deg = Split(klslst, "{")
yol = deg(x)
uzanti = Array(".pdf", ".doc", ".docx", ".rtf", ".xls")

For q = 0 To UBound(uzanti)
If ds.FileExists(yol & "\" & Target & uzanti(q)) = True Then
    [COLOR="Blue"]CreateObject("Shell.Application").Open yol & "\" & Target & [COLOR="DarkRed"]uzanti(q[/COLOR])[/COLOR]
    Exit Sub
End If
Next
Loop While UBound(deg) <> x
End Sub

2. Alternatif:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("a:a")) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub
Cancel = True
Set ds = CreateObject("Scripting.FileSystemObject")
yol = "d:\d-belgeler\epikriz"
Do
If ds.GetFolder(yol).subfolders.Count > 0 Then
    For Each kls In ds.GetFolder(yol).subfolders
        klslst = klslst & "{" & kls
    Next
End If
x = x + 1
deg = Split(klslst, "{")
yol = deg(x)

[COLOR="Blue"]dosya = Dir$(yol & "\" & Target & ".*")
Do While dosya <> ""
CreateObject("Shell.Application").Open yol & "\" & dosya
dosya = Dir$()
Loop[/COLOR]

Loop While UBound(deg) <> x
End Sub

 

[pylor]

sayın leumruk uğraşlarınız için çok teşekkür ederim kodlar çalıştı emeğinize ve elinize sağlık iyi hafta sonları tekrar teşekkür ederim

 

[halit3]

Bu dosyadaki kodları nasıl çalıştıramadınız anlıyamadım. sizin klasörünüzün yanında dosyayı açtığınız zaman E sutünundaki hermangibir hücreye tıkladığınız zaman dosya varsa açıyor yoksa uyarı veriyor.

Klasör ve dosyayı rar dan çıkar yan yana gelsin ve dosyayı aç dene
bununla ilgili resimde ekliyorum dosya klasörün yanında olacak.

Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String
Dim aranan_dosyaadi As String
Dim son As String
 
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("e:e")) Is Nothing Then Exit Sub
If Target.Row > 0 Then
dosyaac
Cancel = True
End If
End Sub
 
 
Sub dosyaac()
son = 0
If ActiveWindow.Selection.Column <> 5 Then Exit Sub
If Val(ActiveWindow.Selection.Row) > 0 Then
aranan_dosyaadi = Cells(ActiveWindow.Selection.Row, 5).Value
Kaynak = ThisWorkbook.Path
Call Liste(Kaynak, "")
If son = 0 Then
MsgBox aranan_dosyaadi & "  Böyle bir dosya yok"
End If
End If
End Sub
 
 
Private Sub Liste(Klasor As String, Uzanti As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).SubFolders
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files
For i = Len(Dir(Dosya)) To 1 Step -1
If Mid(Dir(Dosya), i, 1) = "." Then
Uzanti2 = Mid(Dir(Dosya), i, Len(Dir(Dosya)))
Exit For
End If
Next
If Right(Klasor, 1) <> "\" Then Klasor = Klasor & "\"
If UCase(Dir(Dosya)) = UCase(aranan_dosyaadi & Uzanti2) Then
If ThisWorkbook.Name <> Dir(Dosya) Then
CreateObject("Shell.Application").Open (Klasor & Dir(Dosya))
son = 1
Exit For
End If
End If
Next
On Error GoTo sonraki
For Each f In fL
Kaynak = f.Path
If son = 0 Then
Call Liste(Kaynak, "")
End If
sonraki:
Next
Set fL = Nothing
End Sub