Soru Listboxtaki Dosyaları Açma

[TURKOLOG]

Herkese Merhaba
Listboxta belirlediğim konumdaki dosyaları görüyorum. Ama çift tıkladığımda mevcut konumda dosya yok diyor.

Bir de alt Klasördeki Dosyaları göremiyorum. Ben istiyorum ki seçtiğim konumdan alt klasörler dahil tüm dosyaları görüp çift tıkladığımda açabileyim.

 

[TURKOLOG]

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Workbooks.Open yol & "\" & UserForm1.ListBox1.Value
Rem Unload UserForm1
End Sub

Bu kodlarla dosyalar açılıyor ama belirtilen klasörün altındaki alt klasörde bulunan dosyaları görmüyor. Sadece belirtilen klasörün içindeki dosyalar görünüyor. Alt klasörler için yardım edebilecek olan var mı acaba

 

[halit3]

Userformdaki kodları bu şekilde yap.

Private Sub UserForm_Initialize()

Dim fso As Object
yol = "D:\PERSONEL ORTAK\@PBSNet\GÖREVLENDİRME\2020"
ListBox1.Clear
ListBox1.ColumnCount = 2
ListBox1.ColumnWidths = "0;100;0" 'lisbox'taki sütunların genişliği
Set fso = CreateObject("scripting.filesystemobject")
For Each bul In fso.GetFolder(yol).Files
ListBox1.AddItem
sat1 = ListBox1.ListCount - 1
ListBox1.List(sat1, 0) = bul
ListBox1.List(sat1, 1) = bul.Name
Next
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Workbooks.Open UserForm1.ListBox1.List(ListBox1.ListIndex, 0)
Rem Unload UserForm1
End Sub

 

[TURKOLOG]

Sayın @halit3 Hocam
Tıklayınca tiff tif pdf jpg jpeg docx ne kadar uzantılı dosya varsa hepsini excel olarak açıyor malesef. Hocam tüm dosyaları kendi formatında açsa bir de işlem yapılan dosyayı kapatmasa Hocam çok mu şey istemiş olurum.
Bir de alt klasörleri görmüyor. Istirham etsem koda bakma imkanınız var mı

 

[halit3]

kod:

Private Sub UserForm_Initialize()
yol = "D:\PERSONEL ORTAK\@PBSNet\GÖREVLENDİRME\2020"
ListBox1.Clear
ListBox1.ColumnCount = 2
ListBox1.ColumnWidths = "0;100;0" 'lisbox'taki sütunların genişliği
Liste (yol)
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.GetFolder(yol).Files
ListBox1.AddItem
sat1 = ListBox1.ListCount - 1
ListBox1.List(sat1, 0) = Dosya
ListBox1.List(sat1, 1) = Dosya.Name
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dosya1 = ListBox1.List(ListBox1.ListIndex, 0)
If Dosya 1<> "" Then
CreateObject("Shell.Application").Open (Dosya1)
End If
End Sub

 

[TURKOLOG]

Sayın @halit3 Hocam çok teşekkür ederim. Elinize emeğinize sağlık
Sadece excel dosyalarını açmıyor. Sistemsel bir sorun mu bilmiyorum. Excel türü dosyaların hiçbiri açılmıyor .

 

[halit3]

Userformun ShowModal özelliğini False yap ondan sonra dene

 

[TURKOLOG]

Userformun ShowModal özelliğini False yap ondan sonra dene

Sayın @halit3 Bey çok teşekkür ederim çalıştı.

 

[TURKOLOG]

Arkadaşlar Merhaba;
Dosyada Listbox1 e belirtilen yoldaki dosyaları getirmeyi ve açmayı Sayın @halit3 Beyin yardımı ile yaptım. Kendisine çok teşekkür ederim.
Faydalanmak isteyenler için de dosyayı paylaşıyorum.

Dosyalar listbox1 e geliyor ve tıklanınca açılıyor. Bu sefer de söyle bir şeye ihtiyaç oldu ki :

Listboxta çok fazla dosya olunca arama bulma yönetimine ihtiyacım var
Şöyle ki TextBox1 e yazdığım kelimeyi listbox1 de bulup süzsün
Misal Abdulhakim AVRASİ-123.pdf İsimli dosyayı

rasi yazdığımda da
hakim yazdığımda da
Abd yazdığımda da
Abdulhakim yazdığımda da
avrasi yazdığımda da
DULHA yazdığımda da
123 yazdığımda da

büyük küçük harf ayrımı yapmaksızın arayıp süzüp getirsin.

yine *.pdf yazdığımda tüm pdf uzantılı dosyaları
*.tiff yazdığımda tüm tiff uzantılı dosyaları
*.docx yazdığımda tüm docx uzantılı dosyaları
*.jpeg yazdığımda tüm jpeg uzantılı dosyaları
*.xlsx yazdığımda tüm xlsx uzantılı dosyaları süzüp getirmesi için yardım edebilecek olan var mı acaba

 

[halit3]

Kod

Private Sub UserForm_Initialize()
yol = "C:\Users\YILDIZ\Desktop\ULUSLARARASI İLİŞKİLER"
'yol = ThisWorkbook.Path & "\"
ListBox1.Clear
ListBox1.ColumnCount = 2
ListBox1.ColumnWidths = "0;100;0" 'lisbox'taki sütunların genişliği
Liste (yol)
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.getfolder(yol).Files

If ThisWorkbook.Name <> Dosya.Name Then
If Mid(Dosya.Name, 1, 2) <> "~$" Then
ListBox1.AddItem
sat1 = ListBox1.ListCount - 1
ListBox1.List(sat1, 0) = Dosya
ListBox1.List(sat1, 1) = Dosya.Name
End If
End If
Next

On Error GoTo sonraki
For Each f In fL.getfolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dosya1 = ListBox1.List(ListBox1.ListIndex, 0)
If Dosya1 <> "" Then
CreateObject("Shell.Application").Open (Dosya1)
End If
End Sub

Private Sub TextBox1_Change()
yol = "C:\Users\YILDIZ\Desktop\ULUSLARARASI İLİŞKİLER"
'yol = ThisWorkbook.Path & "\"
ListBox1.Clear
ListBox1.ColumnCount = 2
ListBox1.ColumnWidths = "0;100;0" 'lisbox'taki sütunların genişliği
Liste2 (yol)

End Sub

Private Sub Liste2(yol As String)
Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.getfolder(yol).Files

If ThisWorkbook.Name <> Dosya.Name Then
If Mid(Dosya.Name, 1, 2) <> "~$" Then
If UCase(Dosya.Name) Like "*" & UCase(Replace(Replace(TextBox1, "i", "İ"), "ı", "I")) & "*" Then

ListBox1.AddItem
sat1 = ListBox1.ListCount - 1
ListBox1.List(sat1, 0) = Dosya
ListBox1.List(sat1, 1) = Dosya.Name
End If
End If
End If
Next

On Error GoTo sonraki
For Each f In fL.getfolder(yol).subfolders
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

 

[TURKOLOG]

Kod

Private Sub UserForm_Initialize()
yol = "C:\Users\YILDIZ\Desktop\ULUSLARARASI İLİŞKİLER"
'yol = ThisWorkbook.Path & "\"
ListBox1.Clear
ListBox1.ColumnCount = 2
ListBox1.ColumnWidths = "0;100;0" 'lisbox'taki sütunların genişliği
Liste (yol)
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.getfolder(yol).Files

If ThisWorkbook.Name <> Dosya.Name Then
If Mid(Dosya.Name, 1, 2) <> "~$" Then
ListBox1.AddItem
sat1 = ListBox1.ListCount - 1
ListBox1.List(sat1, 0) = Dosya
ListBox1.List(sat1, 1) = Dosya.Name
End If
End If
Next

On Error GoTo sonraki
For Each f In fL.getfolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dosya1 = ListBox1.List(ListBox1.ListIndex, 0)
If Dosya1 <> "" Then
CreateObject("Shell.Application").Open (Dosya1)
End If
End Sub

Private Sub TextBox1_Change()
yol = "C:\Users\YILDIZ\Desktop\ULUSLARARASI İLİŞKİLER"
'yol = ThisWorkbook.Path & "\"
ListBox1.Clear
ListBox1.ColumnCount = 2
ListBox1.ColumnWidths = "0;100;0" 'lisbox'taki sütunların genişliği
Liste2 (yol)

End Sub

Private Sub Liste2(yol As String)
Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.getfolder(yol).Files

If ThisWorkbook.Name <> Dosya.Name Then
If Mid(Dosya.Name, 1, 2) <> "~$" Then
If UCase(Dosya.Name) Like "*" & UCase(Replace(Replace(TextBox1, "i", "İ"), "ı", "I")) & "*" Then

ListBox1.AddItem
sat1 = ListBox1.ListCount - 1
ListBox1.List(sat1, 0) = Dosya
ListBox1.List(sat1, 1) = Dosya.Name
End If
End If
End If
Next

On Error GoTo sonraki
For Each f In fL.getfolder(yol).subfolders
Liste2 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

Sayın @halit3 Halit Hocam kod çalışıyor ama o kadar ağır çalışıyor ki textbox1 e yazdigimi 20 saniyeden saha uzun sürede yazıyor textbox1 e .
Textbox1 de yazanı silmek istediğimde de 20 saniyeden daha uzun bir sürede textbox1 i temizliyor. Kodu hızlandırma imkanınız var mı bu şekilde çok ağır çalışıyor

 

[halit3]

Sayfanızda formüller çok varsa kod yavaşlar
geçmiş zamanda da size yazdığım kodlar vardı hesaplamaları makro çalıştığında manuel yapacak işlem bittiğinde otomatiğe çevirecek
bu kodları eklerseniz kod hızlanacaktır.

 

[TURKOLOG]

Sayın @halit3 Halit Hocam
Arama yaparken i harfinde sorun çıkarıyor.
Bir de arama dosya sayısına bağlı olarak uzuyor. Ama 100 tane dosya için de süre uzun ama .

 

[TURKOLOG]

Sayfanızda formüller çok varsa kod yavaşlar
geçmiş zamanda da size yazdığım kodlar vardı hesaplamaları makro çalıştığında manuel yapacak işlem bittiğinde otomatiğe çevirecek
bu kodları eklerseniz kod hızlanacaktır.

Hocam excel sayfasinda sadece bu userform var. Hızlandirmak icin Geçmişte yazdınız kodlar derken inanin hatırlayamadım. Kodları Nasıl nerden alıp hizlandiracagimi bilemedim. Yardımcı olursanız çok sevinirim.
Bir de dosya uzantısı ve ya adı
.ini büyük küçük i harfi ile yazdıysam da bulmadı. I ve i harfinde sorun çıkarıyor.

 

[halit3]

yol = "C:\Users\YILDIZ\Desktop\ULUSLARARASI İLİŞKİLER"

Bu bölümde yaklaşık kaç dosya mevcut
Kodlar aksanlı harflerde ve türkçe karekterlerde sorun çıkartır

 

[TURKOLOG]

460 dosya vaR belirttiğim konumda Hocam

 

[halit3]

Farklı bir konu başlığında da benzer sorunuz vardı
Kod bir klasörde veya bir sürücüde çalıştırılıyor ise buradaki dosya sayısı ile hızı orantılı olacaktır.

 

[halit3]

460 dosya vaR belirttiğim konumda Hocam

Textbox1 e her yazı karekteri eklediğinizde veya sildiğinizde bu 460 dosyayı tarayacaktır kod
siz en iyisi bu bölümü bir komut düğmesine atayın. ve oradan çalıştırın

Private Sub TextBox1_Change()
yol = "C:\Users\YILDIZ\Desktop\ULUSLARARASI İLİŞKİLER"
ListBox1.Clear
ListBox1.ColumnCount = 2
ListBox1.ColumnWidths = "0;100;0" 'lisbox'taki sütunların genişliği
Liste2 (yol)

End Sub

 

[TURKOLOG]

Textbox1 e her yazı karekteri eklediğinizde veya sildiğinizde bu 460 dosyayı tarayacaktır kod
siz en iyisi bu bölümü bir komut düğmesine atayın. ve oradan çalıştırın

Private Sub TextBox1_Change()
yol = "C:\Users\YILDIZ\Desktop\ULUSLARARASI İLİŞKİLER"
ListBox1.Clear
ListBox1.ColumnCount = 2
ListBox1.ColumnWidths = "0;100;0" 'lisbox'taki sütunların genişliği
Liste2 (yol)

End Sub

Tamam Hocam dediginiz gibi butona ekleyeyim . Ama i I İ olayı kalacak o zaman