'Option Explicit
Sub TestFichiersRépertoireFSO()
Dim Table As Variant, tim#
Const Répertoire = "H:" ' "H:\Téléchargements"
tim = Timer
'Table = FichiersRépertoireFSO(Répertoire, , "txt")
Table = FichiersRépertoireFSO(Répertoire, , "xls*")
'If not VarType(Table) = vbBoolean Then
If IsArray(Table) Then
Table = TransposeExcel(Table)
MsgBox UBound(Table) & " fichier(s) trouvé(s) dans le répertoire <" & Répertoire & "> en " & Timer - tim & " s/"
ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
ActiveSheet.Range("A1").Resize(UBound(Table)).Value = Table
Else
MsgBox "Aucun fichier dans le répertoire <" & Répertoire & ">"
End If
End Sub
'---------------------------------------------------------------
'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)
'- Return: table à 1 dimension des noms complets des fichiers
' ou False si aucun fichier dans le répertoire
'---------------------------------------------------------------
Function FichiersRépertoireFSO(ByVal NomRépertoire As Variant, _
Optional NoRecycle As Boolean = True, _
Optional Extension As String = "") As Variant
'Tableau résultat static pour être indépendant des appels récursifs
Static TabNomsFichiers() As String
Static NbFichiers As Long
'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 TabNomsFichiers
NbFichiers = 0
'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
err.Clear
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
ReDim Preserve TabNomsFichiers(1 To NbFichiers)
TabNomsFichiers(NbFichiers) = oFile.Path
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
'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, NoRecycle, Extension)
'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
'Return value
If InitialCall Then
FichiersRépertoireFSO = False
If NbFichiers > 0 Then FichiersRépertoireFSO = TabNomsFichiers
End If
Exit Function
TraiteErreur:
'Error #70 Authorisation refusée
'Error #76 Path not found - Cas des noms de répertoires ou fichiers dont le chemin complet > Maximum (247, 259)
'Autre erreur à identifier ?
If Not (err.Number = 70 Or err.Number = 76) Then
MsgBox "FichiersRépertoireFSO erreur #" & err.Number & vbCrLf & "Sur " & NomObjetEnErreur & ""
End If
NomObjetEnErreur = ""
err.Clear
Return
End Function
'--------------------------------------------------------------------
'Fonction de Tranpose selon la logique de WorksheetFunction.Transpose
'sauf que WorksheetFunction.Transpose se limite à 65536 éléments
'alors que cette fonction lève cette limite.
'--------------------------------------------------------------------
Function TransposeExcel(T As Variant) As Variant
Dim tt() As Variant
Dim NbDimensions As Integer
Dim i As Long
Dim j As Long
If Not IsArray(T) Then
MsgBox "Function TransposeExcel: error argument is not an array !"
Exit Function
End If
'1 ou 2 dimensions pour t ?
On Error Resume Next
i = UBound(T, 2)
If Err.Number Then NbDimensions = 1 Else NbDimensions = 2
On Error GoTo 0
'------------------------------------------------------
'Tableau origine 1 dimension
'=> Tableau destination 2 dimensions dont la 2ème est 1
'------------------------------------------------------
If NbDimensions = 1 Then
ReDim tt(LBound(T) To UBound(T), 1 To 1)
For i = LBound(T) To UBound(T)
tt(i, 1) = T(i)
Next i
End If
'----------------------------
'Tableau origine 2 dimensions
'----------------------------
If NbDimensions = 2 Then
'-----------------------------------------------
'Tableau origine 2 dimensions dont la 2ème est 1
'=> Tableau destination 1 dimension
'-----------------------------------------------
If UBound(T, 2) = 1 Then
ReDim tt(LBound(T, 1) To UBound(T, 1))
For i = LBound(T, 1) To UBound(T, 1)
tt(i) = T(i, 1)
Next i
'-------------------------------------------------
'Tableau origine 2 dimensions dont la 2ème est > 1
'=> Tableau destination 2 dimensions inversées
'-------------------------------------------------
Else
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
End If
End If
TransposeExcel = tt
End Function
