Klasörün içindeki tüm alt klasör ve içindeki dosyaların yazdırılması

[desk]

Arkadaşlar forumda bir ara görmüştüm fakat bir türlü bulamadım.

klasörün içindeki tüm alt klasörlerle birlikte içinde bulunan dosyaların yazdırılması konusunda yardımcı olabilirmisiniz.

Aklasörü\ali.xls
Aklasörü\icindeki\veli.xls
Aklasörü\içindeki\mehmet.xls

gibi tüm bilgileri döktürmek istiyorum.

 

[hamitcan]

Not:Yanılmıyorsam bu kodlar Zeki bey'e ait idi.

Sub Start()
Dim klasor As Object
 
Set klasor = CreateObject("Shell.Application").BrowseForFolder _
                    (0, "Lütfen bir klasor seçin !", 1)
                    
Liste (klasor.Items.Item.Path)
AltListe (klasor.Items.Item.Path)
 
Set klasor = Nothing
End Sub
 
Private Sub Liste(yol As String)
Dim dosya As String, i As Long
 
    dosya = Dir(yol & "\*.*")
    i = 1
    While dosya <> ""
        DoEvents
        i = i + 1
        Cells(i, 1) = yol & "\" & dosya
        dosya = Dir
    Wend
End Sub
 
Private Sub AltListe(yol As String)
Dim fL As Object, f As Object, dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
 
On Error GoTo sonraki
For Each f In fL
    dosya = Dir(f.Path & "\*.*")
    
    While dosya <> ""
        DoEvents
        j = [a65000].End(3).Row + 1
        Cells(j, 1) = yol & "\" & dosya
        dosya = Dir
    Wend
    
    AltListe (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

 

[desk]

Evet bu kodu biliyorum fakat bu klasördeki leri normal veriyor ama alt klasördekileri klasör adlarını yazmadan veriyor tüm yoluyla lazim.

 

[hamitcan]

Bir de şunu dener misiniz ?

Sub Start()
Dim klasor As Object
 
Set klasor = CreateObject("Shell.Application").BrowseForFolder _
                    (0, "Lütfen bir klasor seçin !", 1)
                    
Liste (klasor.Items.Item.Path)
AltListe (klasor.Items.Item.Path)
 
Set klasor = Nothing
End Sub
 
Private Sub Liste(yol As String)
Dim dosya As String, i As Long
 
    dosya = Dir(yol & "\*.*")
    i = 1
    While dosya <> ""
        DoEvents
        i = i + 1
        Cells(i, 1) = yol & "\" & dosya
        dosya = Dir
    Wend
End Sub
 
Private Sub AltListe(yol As String)
Dim fL As Object, f As Object, dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
 
On Error GoTo sonraki
For Each f In fL
    dosya = Dir(f.Path & "\*.*")
    
    While dosya <> ""
        DoEvents
        j = [a65000].End(3).Row + 1
        Cells(j, 1) = f.Path & "\" & dosya
        dosya = Dir
    Wend
    
    AltListe (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub