XL 2013 comment récupérer toute l'arborescence d'un dossier dans Excel ou Word

'**************************************************************
'fonction récursive pour lister les fichiers d'un disque ou dossier
'Utilisation de filesystemobject(FSO)
'-------------------------------------
'                          THEME
'recherche D 'amelioration  pour la lenteur de FSO en récursif
'recherche des moyens de controler les erreurs du aux noms trop long  ou fichiers interdit  ou system ou caracteres particuliers
'------------------------------------

'Auteurs Dudu2 et patricktoulon  sur exceldownload
'version 1.5
'Date:08/02/2021
'mise en place du principe (Part name) valable aussi pour (si juste extension demandée:ex;[*.XXX])
'suppression du stockage des erreurs et des msgbox d'erreur
'suppression commentaires
'utilisation d'une fonction de transposition de l'array simplifiée (horizontal(1 dim) To vertical(2 dim))pour palier au limite de la fonction transpose d'excel

'Date:08/02/2021
'accélération du processus
'en ajoutant du test dir non bloquant pour zapper les dossiers
'ne contenant pas de fichier avec l'extension ou la partie du nom demandée
'Date:13/02/2021
'remplacement du bloc  <<if takeit>> par un jumping (etiquette "ScanFolder")
'pour jumper directement sur la boucle des dossiers on  zappe directement la partie du code boucle ofile si pas de fichier
'****************************************************************
Option Explicit
Option Compare Text
Dim Appelcount
Dim countdoss
Function TransposeArray(arr) ' fonction de transposition pour palier au limites de la fonction transpose d'excel
    Dim tbl(), I&: ReDim tbl(LBound(arr) To UBound(arr), 1 To 1)
    For I = LBound(arr) To UBound(arr): tbl(I, 1) = arr(I): Next
    TransposeArray = tbl
End Function
'
Sub listeFSOGOSUB()
    Dim Table As Variant, tim
    ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
    Const Répertoire = "h:\": tim = Timer
    Const Ext$ = "*.*"
    Appelcount = 0    '
    countdoss = 0
    Table = FSO_List_FICHIERS2(Répertoire, Ext)
    If IsArray(Table) Then
        Table = TransposeArray(Table)
        tim = Format(Timer - tim, "#0.000 S")

        MsgBox UBound(Table) & " fichier(s) <""" & Ext & """> trouvé(s) dans le répertoire <" & Répertoire & "> en " & tim & " s/" & _
               vbCrLf & "pour " & Appelcount & " appels de la fonction dans dossier et sous dossier" & vbCrLf & countdoss & " dossiers utilement explorés"
       
        ActiveSheet.Range("A1").Resize(UBound(Table)).Value = Table

    Else
        MsgBox "Aucun fichier dans le répertoire <" & Répertoire & ">" & vbCrLf & "ayant une partie du nom contenant  " & Ext
    End If
End Sub

Function FSO_List_FICHIERS2(ByVal Folder As Variant, Optional PartName As String = "") As Variant
    Static tbl() As String: Static NbFichiers As Long: Static oFSO As Object
    Appelcount = Appelcount + 1
     countdoss = countdoss + 1
Dim oDir As Object, oSubDir As Object, oFile As Object, First_Call As Boolean, TakeIT As Boolean

    If TypeOf Folder Is Object  Then                            'si ce nest pas le premier appel  Foler est un objet folder membre de FSO
        First_Call = False                                      'si ce nest pas le premier appel  on positionne First_Call a false des les 2d appel
        Set oDir = Folder                                       'si ce nest pas le premier appel  Odir est donc un object Folder membre de FSO
    Else                                                        'si c'est le premier appel Folder est de type string
        First_Call = True                                       'si c'est le premier appel first_call est a true
        Erase tbl                                               'si c'est le premier appel on eraze la variable tableau  <<tbl>>
        NbFichiers = 0                                          'si c'est le premier appel on met la variables NbFichiers à 0
        Set oFSO = CreateObject("Scripting.FileSystemObject")   'si c'est le premier appel on créée l'object FSO
        If Right(Folder, 1) <> "\" Then Folder = Folder & "\"   'si c'est le premier appel si le slach de fin on l'ajoute
        Set oDir = oFSO.getfolder(Folder)                       'si c'est le premier appel on instruit l'object Folder<<Odir>>avec le string du dossier
    End If

    TakeIT = True                                               'on met la variable Takeit à true d'office
    ' on ouvre une gestion d'erreur globale (pour les permissions refusées ou les noms portants des caracteres speciaux)
    'la gestion est valable aussi pour la boucle subFolder elle es fermé a chaque fin d'appels récursifs
    On Error Resume Next
    If Len(PartName) > 0 Then TakeIT = Len(Dir(oDir.Path & "\" & PartName)) > 0    'si partname demandé on test de presence de (fichier avec PartName dans le nom) dans le dossier en une seule fois
    If Err.Number <> 0 Or TakeIT = False Then Err.Clear: countdoss = countdoss - 1: GoSub Scanfolder ' si erreur ou TakeIt =false on zappe l'exploration des fichiers on va directement à l'exploration des sous dossiers avec gosub
 
 
    For Each oFile In oDir.Files            'boucle sur les fichiers
        If Err.Number = 0 Then              'si pas d'erreur
            If Len(PartName) = 0 Then       'si pas de PartName demandé on memorise le fichier directement
                NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oFile.Path
            Else                            'si PartName demandé on teste si le nom de fichier like PartName
                If oFile.Name Like PartName Then NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oFile.Path                'Stocke le nom complet du fichier en table
            End If
        End If
        Err.Clear                                       ' on clear l'erreur au cas ou
    Next oFile

Scanfolder:                                             ' etiquette du jumping d'exploration

    For Each oSubDir In oDir.subfolders                 ' boucle sur les dossiers
         
            If Err.Number = 0 Then
            FSO_List_FICHIERS2 oSubDir, PartName        ' on relance la fonction ( appel récursif)
        Else: Err.Clear                                 ' sinon on clear l'erreur si dossier interdit ou special
        End If
    Next oSubDir

    On Error GoTo 0                                     ' ferme la gestion d'erreur globale

' si c'est le premier appel  donc on a lu tout l'arborescence en appels récursifs on peut maintenant instruire le return de la fonction avec le tableau
    If First_Call Then
        FSO_List_FICHIERS2 = False                      ' on met le return de la fonction a false
        If NbFichiers > 0 Then FSO_List_FICHIERS2 = tbl ' si NbFichiers est plus grand que 0 le return de la fonction est la tableau
    End If

End Function

'**********************************************************
'                fonction récursive pour dir vba
'utilisation de Dir VBA
'auteur: patricktoulon Sur DVP et Exceldownloads
'date:09/11/2016
'
'mises a jour
'date:03/15/2018: utilisation d'une collection pour le stockage provisoire des dossiers
'date 07/02/2021:désormais la fonction compile l'array a la fin de l'appel #1 de la fonction (recall=false)
'date 07/02/2021: ajout de l'argument "PartName"
'date 08/02/2021: ajout d'une fonction de transposition simple pour eviter la limite de la fonction transpose de vba pour 2007 et ceux qui n'on pas installé le KB complement de correction du LAA pour 2013 2010 version disque
'date 09/02/2021: ajout de la gestion d'erreur et correction sur les fichiers portant un nom avec des caracteres spéciaux
'                ainsi que les dossiers ou fichiers interdits
'*************************************************************
Option Explicit

Function TransposeArray2(arr) ' fonction de transposition pour palier au limites de la fonction transpose d'excel
    Dim tbl(), I&: ReDim tbl(LBound(arr) To UBound(arr), 1 To 1)
    For I = LBound(arr) To UBound(arr): tbl(I, 1) = arr(I): Next
    TransposeArray2 = tbl
End Function


Sub testDIR_1()
    Dim tim#, T, extension$
    [A1].CurrentRegion.Clear
    extension = "*.*"
    tim = Timer
    T = DirList("h:\") ', PartName:=extension)

    If IsArray(T) Then
        MsgBox Timer - tim & " secondes pour " & UBound(T) & " fichier(s)"
        [A1].Resize(UBound(T)) = TransposeArray2(T)
    Else
        MsgBox "pas de fichier"
    End If

End Sub
Function DirList(Dossier As String, Optional Recall As Boolean = False, Optional PartName As String = "") As Variant
    Dim ItemVu As String, SubFolderCollection As New Collection, I As Long, a As Long, q As Long, criteres, arr1, arr2, subdossier, x
    Static tbl$()    'tbl est statique
    arr1 = Array("a~", "a`", "a^", "a¨", "e`", "e^", "e¨", "i`", "i^", "i¨", "o~", "o`", "o^", "o¨", "u`", "u^", "u¨")    'array caracteres séparés
    arr2 = Array("ã", "à", "â", "ä", "è", "ê", "ë", "ì", "î", "ï", "õ", "ò", "ô", "ö", "ù", "û", "ü")    'array caracteres regroupés
    If Recall = False Then ReDim tbl(0)    ' si recall  on redim un tableau  de zero item (pour la creation du tableau)
    criteres = vbDirectory Or vbSystem Or vbHidden Or vbArchive Or vbReadOnly Or vbNormal
    On Error Resume Next    'gestion des fichiers dossiers system et interdit ou generant une erreur(PerLog,recycle,etc..)
    ItemVu = Dir(Dossier, criteres)
    If Error.Number = 0 Then    ' si pas d'erreur on examine le contenu
        'examen  du dossier courrant
        Do While ItemVu <> vbNullString    'boucle tant que DIR renvoie une chaine
            If ItemVu <> "." And ItemVu <> ".." And Not ItemVu Like "*RECYCLE*" Then
                On Error Resume Next
                If (GetAttr(Dossier & ItemVu) And vbDirectory) = vbDirectory Then    'test Dossier
                    If Err.Number > 0 Then    'si erreur c'est un fichier(particulier ou caracteres particulier)
                        If Err.Number = 53 Then    'si c'est des caracteres bizarres
                            For q = 0 To UBound(arr1): ItemVu = Replace(Replace(ItemVu, arr1(q), arr2(q)), UCase(arr1(q)), UCase(arr2(q))): Next  'replace caracteres
                            If PartName <> "" Then
                                If ItemVu Like PartName Then ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = "erreur !!" & Err.Number & "-->" & Dossier & ItemVu
                            Else
                                ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = "erreur !!" & Err.Number & "-->" & Dossier & ItemVu
                            End If
                        Else
                            'si autre erreur
                            'If PartName <> "" Then
                                'If ItemVu Like PartName Then ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = "erreur !!" & Err.Number & "-->" & dossier & ItemVu
                            'Else
                                ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = "erreur !!" & Err.Number & "-->" & Dossier & ItemVu
                            'End If
                        End If
                        'si dossier
                    Else
                        SubFolderCollection.Add Dossier & ItemVu    'sinon ajout dans la collection de dossier
                    End If
                    Err.Clear
                Else    'sinon c'est un fichier et pas un concombre:)

                    'If ItemVu Like PartName Then
                    If PartName <> "" Then
                        If ItemVu Like PartName Then ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = Dossier & ItemVu
                    Else
                        ReDim Preserve tbl(UBound(tbl) + 1): tbl(UBound(tbl) - 1) = Dossier & ItemVu
                    End If
                End If
            End If
            ItemVu = Dir()
        Loop
    Else
        Err.Clear    'si erreur a la racine du dir actuel
    End If
    'examen des sub dossier appel récursif
    For Each subdossier In SubFolderCollection
        DirList subdossier & "\", True, PartName
    Next subdossier
    DirList = False
    If Not Recall Then DirList = tbl  ' return du tableau (apres le dernier appel récursif )'economie de 0.3000 secondes
End Function