Liste de fichiers avec dossiers ET sous dossiers

'----------------------------------------------------------------------------
'   Outils / Références A COCHER  Microsoft Scripting Runtime
'                                 Microssoft Shell Controls and Automation
'----------------------------------------------------------------------------
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (x As Currency) As Boolean
 
Option Explicit
 
Dim i As Long, k As Long
Dim oShell As Shell, oFolder As Shell32.Folder, oFolderItem As Shell32.FolderItem
Dim FSO As FileSystemObject, Dossier As Scripting.Folder, Fichier As Scripting.File
Dim Debut As Currency, Fin As Currency, Freq As Currency, NbDossiers As Long
Dim TypeFichier As String
 
Private Sub ExtractionDonnees(sDossier As String)
Dim LastRow As Long, j As Long
    Application.ScreenUpdating = False
 
    With Feuil1
        .Cells.Clear
        .Range("A1") = "Nom"
        .Range("B1") = "Taille"
        .Range("C1") = "Type"
        .Range("D1") = "Date Modification"
        .Range("E1") = "Date Création"
        .Range("F1") = "Date Dernier Accès"
        .Range("G1") = "Attributs"
        .Range("H1") = "Etat"
        .Range("I1") = "Propriétaire"
        .Range("J1") = "Auteur"
        .Range("K1") = "Titre"
        .Range("L1") = "Sujet"
        .Range("M1") = "Catégorie"
        .Range("N1") = "Pages"
        .Range("O1") = "Commentaires"
        .Range("P1") = "Copyright"
        .Range("Q1") = "Artiste"
        .Range("R1") = "Titre Album"
        .Range("S1") = "Année"
        .Range("T1") = "N° de Piste"
        .Range("U1") = "Genre"
        .Range("V1") = "Durée"
        .Range("W1") = "Vitesse Transmission"
        .Range("X1") = "Protégé"
        .Range("Y1") = "Modele Appareil Photo"
        .Range("Z1") = "Date Cliché"
        .Range("AA1") = "Dimension"
        .Range("AB1") = "Largeur"
        .Range("AC1") = "Hauteur"
        .Range("AD1") = "Nom Episode"
        .Range("AE1") = "Description Programme"
        .Range("AF1") = "Taille Echantillon Audio"
        .Range("AG1") = "Fréquence Echantillonnage"
        .Range("AH1") = "Chemin"
    End With
 
    k = 2
 
    Set oShell = New Shell
    Set FSO = New Scripting.FileSystemObject
    Set Dossier = FSO.GetFolder(sDossier)
 
    NbDossiers = NbDossiers + 1
    For Each Fichier In Dossier.Files
        If UCase$(TypeFichier) = UCase$(FSO.GetExtensionName(Fichier)) Then
            Set oFolder = oShell.Namespace(Dossier.Path)
            Set oFolderItem = oFolder.ParseName(Fichier.Name)
            i = 1
            With Feuil1
                For j = 0 To 34
                    If j <> 31 Then
                        .Range(NumCol2Lettre(i) & k) = oFolder.GetDetailsOf(oFolderItem, j)
                        i = i + 1
                    End If
                Next j
                .Range(NumCol2Lettre(i - 1) & k) = sDossier
                Application.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & k - 1
                k = k + 1
            End With
        End If
    Next Fichier
 
    RchRecursive Dossier
    FormatAttributs
 
    With Feuil1
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A1:AH" & LastRow).WrapText = False
        .Range("1:1").Font.Bold = True
        .Rows("2:2").Select
        ActiveWindow.FreezePanes = True
 
        .Columns("A:AH").EntireColumn.AutoFit
        .Range("A1:AH1").Interior.ColorIndex = 36
        .Range("D2:F" & LastRow).NumberFormat = "dd/mm/yyyy hh:mm:ss"
        .Range("AF2:AF" & LastRow).NumberFormat = "dd/mm/yyyy hh:mm:ss"
    End With
 
    Tri
 
    Feuil1.Activate
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
 
    Set FSO = Nothing
    Set oShell = Nothing
    Set Dossier = Nothing
    Set oFolder = Nothing
    Set oFolderItem = Nothing
    Set Fichier = Nothing
 
    Application.ScreenUpdating = True
End Sub
 
Private Sub FormatAttributs()
Dim LastRow As Long
    LastRow = Feuil1.Range("G" & Rows.Count).End(xlUp).Row + 1
    Feuil1.Range("G2:G" & LastRow).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
End Sub
 
Private Function NumCol2Lettre(iNumCol As Long) As String
Dim i As Long, sStr As String
    i = iNumCol
    sStr = ""
    Do While i > 0
        sStr = Chr$(((i - 1) Mod 26) + 65) & sStr
        i = (i - 1) \ 26
    Loop
    NumCol2Lettre = sStr
End Function
 
Private Sub RchRecursive(sFolder As Scripting.Folder)
Dim SousDossier As Scripting.Folder
Dim j As Long
 
    For Each SousDossier In sFolder.SubFolders
        Set Dossier = FSO.GetFolder(SousDossier)
        NbDossiers = NbDossiers + 1
        For Each Fichier In SousDossier.Files
            If UCase$(TypeFichier) = UCase$(FSO.GetExtensionName(Fichier)) Then
                Set oFolder = oShell.Namespace(Dossier.Path)
                Set oFolderItem = oFolder.ParseName(Fichier.Name)
                i = 1
                With Feuil1
                    For j = 0 To 34
                        If j <> 31 Then
                            .Range(NumCol2Lettre(i) & k) = oFolder.GetDetailsOf(oFolderItem, j)
                            i = i + 1
                        End If
                    Next j
                    .Range(NumCol2Lettre(i - 1) & k) = sFolder
                    k = k + 1
                End With
            End If
            Application.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & k
        Next Fichier
 
        RchRecursive SousDossier
 
    Next SousDossier
End Sub
 
Sub SelDossier()
Dim sChemin As String
 
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner le Dossier à traiter"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            TypeFichier = InputBox( _
"Donnez seulement le type de fichier (par exemple pdf, xls, doc, jpg ou dxf etc...)" _
, "TYPE DE FICHIER", "stl")
            QueryPerformanceCounter Debut
            NbDossiers = 0
            ExtractionDonnees .SelectedItems(1)
 
            QueryPerformanceCounter Fin
            QueryPerformanceFrequency Freq
 
            Application.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & k - 2 & " / " & Format((Fin - Debut) / Freq, "0.00 s")
        End If
        Feuil1.Range("C1").Select
    End With
End Sub
 
Private Sub Tri()
Dim LastRow As Long
    LastRow = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
    Feuil1.Range("A2:AH" & LastRow).Sort Key1:=Feuil1.Range("A2"), Order1:=xlAscending, Key2:=Feuil1.Range("B2") _
                                                                                              , Order2:=xlAscending, Key3:=Feuil1.Range("C2"), Order3:=xlAscending, Header:= _
                                         xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                                         DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
                                         xlSortNormal
End Sub