'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
'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
'On ne traite pas ces répertoires
If oDir.Name = "System Volume Information" _
Or (NoRecycle And oDir.Name = "$RECYCLE.BIN") Then Exit Function
'On ne traite pas les répertoire ne contenant pas de fichiers avec extension
If Len(Extension) = 0 Then
TakeIt = True
Else
If Len(Dir(oDir.Path & "\" & Extension)) > 0 Then TakeIt = True Else TakeIt = False
End If
If TakeIt Then
'Parcours des fichiers du répertoire en cours
On Error Resume Next
For Each oFile In oDir.Files
If Err.Number = 0 Then
'Test si correspndance de l'extension
If Len(Extension) = 0 Then
TakeIt = True
Else
If 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
Else
'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
Err.Clear
End If
Next oFile
On Error GoTo 0
End If
'Parcours des sous-répertoires du répertoire en cours
For Each oSubDir In oDir.subfolders
'Appels recursifs identifiés par le type Object de l'argument OsubDir
Call FichiersRépertoireFSO(oSubDir, NoRecycle, Extension)
Next oSubDir
'Return value
If InitialCall Then
FichiersRépertoireFSO = False
If NbFichiers > 0 Then FichiersRépertoireFSO = TabNomsFichiers
End If
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
