Microsoft 365 lister des fichiers

Option Explicit
Option Compare Text

'---------------------------------------------------------------
'Liste des fichiers de l'arborescence complète d'un répertoire
'par la "méthode FileSystemObject"
'
'- NomRépertoire: chaine du nom du répertoire concerné
'                 (avec ou sans '\' final)
'
'- NoRecycle: True (valeur par défaut) pour ne pas avoir les
'             fichiers de la poubelle dans la liste résultat
'             si NomRépertoire est une lettre de lecteur (drive)
'
'- Extension: "Pattern" / modèle de l'extension des fichiers à
'             sélectionner ("txt", "xls*" ou "" pour tous)
'
'- DateCréation: True retourne la date de création en 2ème
'                     dimension
'
'- DateModification: True retourne la date de Modification en
'                    2ème dimension
'
'- Taille: True retourne la taille en 2ème dimension
'
'- Return: Table à 1 dimension des noms complets des fichiers
'          Table à 2 dimensions si DateCréation = True,
'                            et/ou DateModification = True,
'                            et/ou Taille = True.
'          ou False si aucun fichier dans le répertoire
'---------------------------------------------------------------
Function FichiersRépertoireFSO(ByVal NomRépertoire As Variant, _
                               Optional SousRépertoires As Boolean = True, _
                               Optional NoRecycle As Boolean = True, _
                               Optional Extension As String = "", _
                               Optional DateCréation As Boolean = False, _
                               Optional DateModification As Boolean = False, _
                               Optional Taille As Boolean = False) As Variant
                            
    'Tableau résultat static pour être indépendant des appels récursifs
    Static TabFichiers() As String
    Static NbFichiers As Long
    Static Dimension2 As Integer
    Static Dimension2DateCréation As Integer
    Static Dimension2DateModification As Integer
    Static Dimension2Taille As Integer
  
    'Variable du FileSystemObject commune à toutes les instances de la fonction
    Static oFSO As Object
  
    'Variable spécifiques à une instance de la fonction
    Dim oDir As Object
    Dim oSubDir As Object
    Dim oFile As Object
    Dim InitialCall As Boolean
    Dim TakeIt As Boolean
    Dim NomObjetEnErreur As String
  
    'Appel recursif de cette fonction (par elle-même ci-dessous)
    If TypeOf NomRépertoire Is Object  Then
        InitialCall = False
      
        'Valorise l'objet Folder
        Set oDir = NomRépertoire
  
    'Appel initial
    Else
         InitialCall = True
      
        'Table résultat
        Erase TabFichiers
        NbFichiers = 0
        Dimension2 = IIf(DateCréation, 1, 0) + IIf(DateModification, 1, 0) + IIf(Taille, 1, 0)
        If Dimension2 > 0 Then
            Dimension2 = 1 + Dimension2
            Dimension2DateCréation = 1 + IIf(DateCréation, 1, 0)
            Dimension2DateModification = Dimension2DateCréation + IIf(DateModification, 1, 0)
            Dimension2Taille = Dimension2DateModification + IIf(Taille, 1, 0)
        End If
      
        'File System Object
        Set oFSO = CreateObject("Scripting.FileSystemObject")
      
        'Complémente éventuellement le nom du répertoire avec '\'
        If Right(NomRépertoire, 1) <> "\" Then NomRépertoire = NomRépertoire & "\"
      
        'Valorise l'objet Folder
        Set oDir = oFSO.GetFolder(NomRépertoire)
    End If
  
    'Si option NoRecycle et répertoire poubelle on ne traite pas
    If NoRecycle And Len(oDir.Name) = 12 Then
        If UCase(oDir.Name) = "$RECYCLE.BIN" Then Exit Function
    End If
  
    'Si le répertoire est "System Volume Information" on ne traite pas
    If oDir.Name = "System Volume Information" Then Exit Function
  
    'Vérifie si le répertoire contient des fichiers avec l'extension
    If Len(Extension) = 0 Then
        TakeIt = True
    Else
         'Il faut couvrir la fonction Dir() par un On Error pour intercepter ses erreurs:
        'Erreur #52:
        '> Accès refusé
        '> Un ou plusieurs caractères du nom du répertoire sont codés en Unicode
        'Erreurs #53:
        '> La longueur du chemin est > longueur maxi
        'Erreurs qui sinon vont se manifester ultérieurement dans la boucle "For Each oSubDir In oDir.subfolders".
        On Error Resume Next
        TakeIt = Len(Dir(oDir.Path & "\*." & Extension)) > 0
        If Err.Number <> 0 Then TakeIt = True
        On Error GoTo 0
    End If

    'On n'examine les fichiers du répertoire que s'il contient des fichiers avec l'extension
    If TakeIt Then
        On Error Resume Next
        For Each oFile In oDir.Files
            If Err.Number = 0 Then
                'Test si correspondance de l'extension
                If Len(Extension) = 0 Then
                    TakeIt = True
                Else
                    If oFSO.GetExtensionName(oFile.Name) Like Extension Then TakeIt = True Else TakeIt = False
                End If
              
                'Stocke le nom complet du fichier en table
                If TakeIt Then
                    NbFichiers = NbFichiers + 1
                    If Dimension2 = 0 Then
                        ReDim Preserve TabFichiers(1 To NbFichiers)
                        TabFichiers(NbFichiers) = oFile.Path
                    Else
                        ReDim Preserve TabFichiers(1 To Dimension2, 1 To NbFichiers)
                        TabFichiers(1, NbFichiers) = oFile.Path
                        'Récupère la date de création
                        If DateCréation Then TabFichiers(Dimension2DateCréation, NbFichiers) = oFile.DateCreated
                        'Récupére la date de dernière modification
                        If DateModification Then TabFichiers(Dimension2DateModification, NbFichiers) = oFile.DateLastModified
                        'Récupére la taille du fichier
                        If Taille Then TabFichiers(Dimension2Taille, NbFichiers) = Left(oFile.Size, 10)
                    End If
                End If
          
            'Fichier en erreur
            Else
                NomObjetEnErreur = "Fichier <"
                If oFile Is Nothing _
                Then NomObjetEnErreur = NomObjetEnErreur & "Nothing" & ">" _
                Else NomObjetEnErreur = NomObjetEnErreur & oFile.Name & ">"
                GoSub TraiteErreur
            End If
        Next oFile
        On Error GoTo 0
    End If
  
    If SousRépertoires Then
        'Parcours des sous-répertoires du répertoire en cours
        On Error Resume Next
        For Each oSubDir In oDir.subfolders
            If Err.Number = 0 Then
                'Appels recursifs identifiés par le type Object de l'argument OsubDir
                 Call FichiersRépertoireFSO(oSubDir, SousRépertoires, NoRecycle, Extension, DateCréation, DateModification, Taille)
          
            'Répertoire en erreur
            Else
                NomObjetEnErreur = "Répertoire <"
                If oSubDir Is Nothing _
                Then NomObjetEnErreur = NomObjetEnErreur & "Nothing" & ">" _
                Else NomObjetEnErreur = NomObjetEnErreur & oSubDir.Path & ">"
                GoSub TraiteErreur
            End If
        Next oSubDir
        On Error GoTo 0
    End If
  
    'Return value
    If InitialCall Then
        If NbFichiers > 0 Then
            If Dimension2 = 0 Then
                FichiersRépertoireFSO = TabFichiers
            Else
                FichiersRépertoireFSO = Transpose(TabFichiers)
            End If
        Else
            FichiersRépertoireFSO = False
        End If
    End If
    Exit Function
  
TraiteErreur:
    Select Case Err.Number
        'Error #70 Authorisation refusée
        Case 70
            MsgBox "Accès refusé pour le fichier <" & NomObjetEnErreur & ">."
          
        'Error #76 Path not found - Cas des noms de répertoires ou fichiers dont le chemin complet > Maximum (247, 259)
        Case 76
            MsgBox "Nom trop long pour le fichier <" & NomObjetEnErreur & ">."
      
        'Autre erreur à identifier ?
        Case Else
            MsgBox "FichiersRépertoireFSO erreur #" & Err.Number & vbCrLf & "Sur " & NomObjetEnErreur & ""
    End Select
  
    NomObjetEnErreur = ""
    Err.Clear
    Return
End Function

'---------
'Transpose
'---------
Private Function Transpose(t As Variant) As Variant
    Dim tt() As Variant
    Dim i As Long
    Dim j As Long
  
    ReDim tt(LBound(t, 2) To UBound(t, 2), LBound(t, 1) To UBound(t, 1))
  
    For i = LBound(t, 2) To UBound(t, 2)
        For j = LBound(t, 1) To UBound(t, 1)
            tt(i, j) = t(j, i)
        Next j
    Next i
  
    Transpose = tt
End Function

Option Explicit
Sub ListerLesFichiers()
    Dim TabFichiers As Variant
    Dim Répertoire As String
    Dim i As Long
  
    Répertoire = [a1].Value
  
    TabFichiers = FichiersRépertoireFSO(Répertoire)
    'ActiveSheet.Columns(1).ClearContents
                                      
    If VarType(TabFichiers) = vbBoolean Then
        MsgBox "Aucun fichier en répertoire <" & Répertoire & ">"
    Else
        If UBound(TabFichiers) <= 65535 Then
            ActiveSheet.[A2].Resize(UBound(TabFichiers), 2).Value = Application.Transpose(TabFichiers)
        Else
            ActiveSheet.[A2].Value = "Utiliser un Transpose codé."
        End If
    End If
  
    For i = 1 To UBound(TabFichiers, 1)
        'Ajoute l'Hyperlien
        ActiveSheet.Hyperlinks.Add Anchor:=[A2].Offset(i - 1), _
                                   Address:=[A2].Offset(i - 1).Value
    Next i
  
    Columns("B:B").Delete Shift:=xlToLeft
    '[a1] = [a1].Value
End Sub