Dosya ve klasör listeleme

[konas06]

Listeleme ile ilgili bilgiyi ekte bulunan dosyada belirttiğim şekilde listeme imkanımız var mıdır.
"halit3" adlı hocamızın "Alt dosya ve klasör" konusunda verdiği kodu kullanarak 2.sayfada bir listeleme yaptım ancak bu ihtiyacımı karşılamıyor.
Sayfa1 deki gibi yapmamız mümkün müdür.
Not: Konu bütünlüğü bozulma endişesiyle yeni konu açarak bilgi almak istiyorum.

 

[halit3]

Bu kodu bir dene

'Kaynak = ThisWorkbook.Path & "\A.Ş"

Sub verial()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path

Cells.ClearContents
Cells.Hyperlinks.Delete
Cells.Font.ColorIndex = 0

Cells(1, 1) = "İSİMLER"
sut = 2
sat = 1
eksi = 0

Set fL = CreateObject("Scripting.FileSystemObject")
deg1 = Split(Kaynak, "\")
'Cells(1, 1).Value = deg1(UBound(deg1)) 'fL.GetBaseName(kaynak)
Cells(1, 1).Hyperlinks.Add Anchor:=Cells(1, 1), Address:=Kaynak, SubAddress:="" & firstAddress, TextToDisplay:=deg1(UBound(deg1))

For Each f In fL.GetFolder(Kaynak).subfolders
'Cells(sat, sut) = f.Name
Cells(sat, sut).Hyperlinks.Add Anchor:=Cells(sat, sut), Address:=f.Path, SubAddress:="" & firstAddress, TextToDisplay:=f.Name
tarih = f.Name
For Each ft In fL.GetFolder(f.Path).subfolders
sut = sut + 1
'Cells(sat, sut) = ft.Name
Cells(sat, sut).Hyperlinks.Add Anchor:=Cells(sat, sut), Address:=ft.Path, SubAddress:="" & firstAddress, TextToDisplay:=ft.Name

For Each fk In fL.GetFolder(ft.Path).subfolders
sut = sut + 1
If sut >= 4 Then
End If
'Cells(sat, sut - eksi) = fk.Name
Cells(sat, sut - eksi).Hyperlinks.Add Anchor:=Cells(sat, sut - eksi), Address:=fk.Path, SubAddress:="" & firstAddress, TextToDisplay:=fk.Name

sut2 = 4
For Each fy In fL.GetFolder(fk.Path).Files
sut2 = sut2 + 1
'Cells(sat, sut2) = fL.GetBaseName(fy.Name)
Cells(sat, sut2).Hyperlinks.Add Anchor:=Cells(sat, sut2), Address:=fy, SubAddress:="" & firstAddress, TextToDisplay:=fL.GetBaseName(fy.Name)


Next
sat = sat + 1
If sut >= 4 Then
eksi = 1
End If

If sut = 5 Then
sut = 2
End If
Next
eksi = 0
Next
sut = 2
Next

MsgBox "işlem tamam"

End Sub

 

[konas06]

Bu kodu bir dene

'Kaynak = ThisWorkbook.Path & "\A.Ş"

Sub verial()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path

Cells.ClearContents
Cells.Hyperlinks.Delete
Cells.Font.ColorIndex = 0

Cells(1, 1) = "İSİMLER"
sut = 2
sat = 1
eksi = 0

Set fL = CreateObject("Scripting.FileSystemObject")
deg1 = Split(Kaynak, "\")
'Cells(1, 1).Value = deg1(UBound(deg1)) 'fL.GetBaseName(kaynak)
Cells(1, 1).Hyperlinks.Add Anchor:=Cells(1, 1), Address:=Kaynak, SubAddress:="" & firstAddress, TextToDisplay:=deg1(UBound(deg1))

For Each f In fL.GetFolder(Kaynak).subfolders
'Cells(sat, sut) = f.Name
Cells(sat, sut).Hyperlinks.Add Anchor:=Cells(sat, sut), Address:=f.Path, SubAddress:="" & firstAddress, TextToDisplay:=f.Name
tarih = f.Name
For Each ft In fL.GetFolder(f.Path).subfolders
sut = sut + 1
'Cells(sat, sut) = ft.Name
Cells(sat, sut).Hyperlinks.Add Anchor:=Cells(sat, sut), Address:=ft.Path, SubAddress:="" & firstAddress, TextToDisplay:=ft.Name

For Each fk In fL.GetFolder(ft.Path).subfolders
sut = sut + 1
If sut >= 4 Then
End If
'Cells(sat, sut - eksi) = fk.Name
Cells(sat, sut - eksi).Hyperlinks.Add Anchor:=Cells(sat, sut - eksi), Address:=fk.Path, SubAddress:="" & firstAddress, TextToDisplay:=fk.Name

sut2 = 4
For Each fy In fL.GetFolder(fk.Path).Files
sut2 = sut2 + 1
'Cells(sat, sut2) = fL.GetBaseName(fy.Name)
Cells(sat, sut2).Hyperlinks.Add Anchor:=Cells(sat, sut2), Address:=fy, SubAddress:="" & firstAddress, TextToDisplay:=fL.GetBaseName(fy.Name)


Next
sat = sat + 1
If sut >= 4 Then
eksi = 1
End If

If sut = 5 Then
sut = 2
End If
Next
eksi = 0
Next
sut = 2
Next

MsgBox "işlem tamam"

End Sub

Çok güzel oldu.

Hocam bu klasör-dosya kurgusuna göre oluşturulan bir kod sanırım değil mi?
Şunu demek istiyorum, son kademe dosyadan sonra gelecek klasör belge yada dosya için koda müdahale etmek gerekecek sanırım.
Bunu başlangıç noktasını vererek son belgeye kadar ilerlemesi sağlanabilir mi?

 

[halit3]

bu kod daha iyi oldu

Dim sayi
Dim sat
Sub klasör_dosya3()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Klasörü Seçin", 50, &H0)
If Klasor Is Nothing Then Exit Sub
Kaynak = Klasor.self.Path
'Kaynak = ThisWorkbook.Path & "\deneme"
Cells.ClearContents
Cells.Hyperlinks.Delete
Cells.Font.ColorIndex = 0

deg1 = Split(Kaynak, "\")
Cells(1, 1).Value = deg1(UBound(deg1))
sat = 1
If UBound(deg1) > 0 Then
sayi = UBound(deg1)
End If
Liste (Kaynak)
MsgBox "işlem tamam"
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

deg1 = Split(yol, "\")
If UBound(deg1) > 0 Then
sut = UBound(deg1) + 1 - sayi
End If

'Cells(sat, sut) = fL.GetBaseName(yol) 'dosya.Name
Cells(sat, sut).Hyperlinks.Add Anchor:=Cells(sat, sut), Address:=yol, SubAddress:="" & firstAddress, TextToDisplay:=fL.GetBaseName(yol)
fL.GetBaseName (yol)

sut = sut + 1

If fL.GetFolder(yol).Files.Count > 0 Then
sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For Each dosya In fL.GetFolder(yol).Files
'Cells(sat, sut) = fL.GetBaseName(dosya.Name)  'dosya.Name
Cells(sat, sut).Hyperlinks.Add Anchor:=Cells(sat, sut), Address:=dosya, SubAddress:="" & firstAddress, TextToDisplay:=fL.GetBaseName(dosya.Name)
'sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
sut = sut + 1
Next
End If

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
sonraki:
Next

End Sub

 

[konas06]

Hocam ilginiz için teşekkür ederim.
Köprüleme de yapabilir miyiz.

Sonrasında artık bu geliştirmeye uygun bir yapı oldu.

Zamanı olan ilgilenebilecek ustalar için mümkünse bir iki rica da bulunmak istiyorum.

Örneğin listelemenin bir üst satında, yine klasör ve dosya yapısı sabit kalmak kaydıyla,
uzantıya göre arama seçeneği eklenebilir, yazdırma seçenekleri konabilir.

Forumda bir çok konudaki ihtiyacı karşılayacak hale getirilebilir.

(Tüm klasör, dosya ve belge listelemek ve yine resim, pdf, java vb dosyaları listelemek ve yazdırmak konuları ile ilgili)

Tekrar teşekkür ederim. Ellerinize sağlık.

 

[halit3]

4 nolu mesajdaki kod güncellendi

 

[konas06]

Teşekkürler.

 

[konas06]

Benim gibi, araştırıp bulamayanlar için,
Seçim konumundan itibaren tüm ögeleri (Klasör, Dosya ve Belge) listelemek ve köprülemek için Halit3 Beyin verdiği kodu ekli dosyaya ekliyorum.
Daha fazla kişinin istifade edeceğini düşünüyorum.