Alt klasorde dosya ozellikleri

[cellswhite]

İyi akşamlar,

Emeği geçen herkese teşekkurler.Forumdan buldugum kod aşağıdadır.

Sub DOSYA_ÖZELLİKLERİ()
    Dim Klasör As Object, Klasör_Yolu As String, dosya As Object, Satır As Long, X As Integer

    On Error Resume Next

    Application.ScreenUpdating = False

    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
    Klasör_Yolu = Klasör.Items.Item.Path
    If Klasör_Yolu = "" Then Exit Sub
    Cells.ClearContents
    Range("A1") = "Dosya Adı"

    For Each dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Klasör_Yolu).Files
        Satır = Satır + 1
        Set dosya = CreateObject("Shell.Application").Namespace(Klasör).ParseName(dosya.Name)
        Cells(Satır + 1, "A") = dosya.Name
        Cells(Satır + 1, "A").Hyperlinks.Add Anchor:=Cells(Satır + 1, "A"), Address:=dosya.Path, TextToDisplay:=dosya.Name

        For X = 1 To 40
            Cells(1, X + 1) = CreateObject("Shell.Application").Namespace(Klasör).GetDetailsOf("", X)
            Cells(Satır + 1, X + 1) = CreateObject("Shell.Application").Namespace(Klasör).GetDetailsOf(dosya, X)
        Next
    Next

    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Bu ilgili klasor için çalışıyor yalnız alt klasorlerde de çalışmasını istiyorum.
Nasıl modifiye edilebilir.Destek verebilirmisiniz.

İyi akşamlar.

 

[cellswhite]

Merhaba,
Sorumun cevabını forum içerisinde buldum emeği geçenlere teşekkurler.