'**************************************************************
'fonction récursive pour lister les fichiers d'un disque ou dossier
'Utilisation de filesystemobject(FSO)
'auteur: Dudu2 sur exceldownload
'Date:07/02/2021
'Modifiée par patricktoulon le 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
'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))
'****************************************************************
Option Explicit
Option Compare Text
Sub TestListFichierFso()
Dim Table As Variant, tim#: Const Répertoire = "c:\": tim = Timer
ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
Table = FSO_List_FICHIERS(Répertoire, "*.txt")
If IsArray(Table) Then
Table = TransposeArray(Table)
MsgBox UBound(Table) & " fichier(s) trouvé(s) dans le répertoire <" & Répertoire & "> en " & Timer - tim & " s/"
ActiveSheet.Range("A1").Resize(UBound(Table)).Value = Table
Else
MsgBox "Aucun fichier dans le répertoire <" & Répertoire & ">"
End If
End Sub
Function FSO_List_FICHIERS(ByVal NomRépertoire As Variant, Optional PartName As String = "") As Variant
'Tableau résultat static pour être indépendant des appels récursifs
Static TabNomsFichiers() As String: Static NbFichiers As Long: Static oFSO As Object
Dim oDir As Object, oSubDir As Object, oFile As Object, InitialCall As Boolean, TakeIT As Boolean
If TypeOf NomRépertoire Is Object Then
InitialCall = False
Set oDir = NomRépertoire 'Valorise l'objet Folder
Else 'si Appel initial
InitialCall = True
Erase TabNomsFichiers 'Table résultat
NbFichiers = 0
Set oFSO = CreateObject("Scripting.FileSystemObject") 'File System Object
If Right(NomRépertoire, 1) <> "\" Then NomRépertoire = NomRépertoire & "\" 'Complémente éventuellement le nom du répertoire avec '\'
Set oDir = oFSO.GetFolder(NomRépertoire) 'Valorise l'objet Folder
End If
'Si op répertoire poubelle on ne traite pas\\\\
'pour une liste complete :16 secondes perdues sur C avec 234000 ////4 secondes perdues sur h avec 4593 fichiers
'If oDir.Name = "$RECYCLE.BIN" Or oDir.Name = "System Volume Information" Then Exit Function
'Vérifie si le répertoire contient au moins un fichier contenat lePartName dans son nom
'On Error Resume Next
If Len(PartName) = 0 Then TakeIT = True Else TakeIT = True: TakeIT = Len(Dir(oDir.Path & "\" & PartName)) > 0
If Err.Number <> 0 Then TakeIT = True: On Error GoTo 0
'On n'examine les fichiers du répertoire que s'il contient des fichiers avec le PartName donc TakeIt =true
If TakeIT Then
On Error Resume Next
For Each oFile In oDir.Files
If Err.Number = 0 Then
If Len(PartName) = 0 Then TakeIT = True Else If oFile.Name Like PartName Then TakeIT = True Else TakeIT = False
If TakeIT Then NbFichiers = NbFichiers + 1: ReDim Preserve TabNomsFichiers(1 To NbFichiers): TabNomsFichiers(NbFichiers) = oFile.Path 'Stocke le nom complet du fichier en table
Err.Clear 'Fichier en erreur ou examen du dossierinterdit
End If
Next oFile
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
Call FSO_List_FICHIERS(oSubDir, PartName) 'Appels recursifs identifiés par le type Object de l'argument OsubDir
Err.Clear 'dossier en erreur ou examen du dossier interdit
End If
Next oSubDir
On Error GoTo 0
'Return value
If InitialCall Then
FSO_List_FICHIERS = False
If NbFichiers > 0 Then FSO_List_FICHIERS = TabNomsFichiers
End If
End Function
Function TransposeArray(arr)
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
