'Option Explicit
Sub TestFichiersRépertoireFSO()
Dim Table As Variant, tim#
Const Répertoire = "c:" ' "H:\Téléchargements"
tim = Timer
'Table = FichiersRépertoireFSO(Répertoire, , "txt")
Table = FichiersRépertoireFSO(Répertoire, , "txt")
'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
Dim x As Variant
'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 oDir.Name = "$RECYCLE.BIN") Then Exit Function
'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
TakeIt = True
'La fonction Dir() introduit des erreurs #52 ou #53 sur les objets Folder
'de la boucle "For Each oSubDir In oDir.subfolders" ci-dessous.
'IL NE FAUT PAS L'UTILISER !!!
'SI SI IL FAUT L UTILISER !!!!!! :):):):)
On Error Resume Next
x = True
x = Dir(oDir.Path & "\*." & Extension) <> vbNullString
If Err.Number > 0 Or Not x Then TakeIt = False: Err.Clear: x = vbNull
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
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, 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
