'**************************************************************
'fonction récursive pour lister les fichiers d'un disque ou dossier
'Utilisation de filesystemobject(FSO)
'sur la base de la version de Dudu2 sur exceldownload
'Modifiée par patricktoulon
''version 1.5
'Date:08/02/2021
'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))
'Date: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
'Date:13/02/2021
'remplacement du test if takeit par un jumping (etiquette "ScanFolder")
'pour jumper directement sur la boucle des dossiers on zappe directement la partie du code boucle ofile
'****************************************************************
Option Explicit
Option Compare Text
Dim Appelcount
Dim countdoss
'
Sub listeFSO0x()
Dim Table As Variant, tim
ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
Const Répertoire = "c:\": tim = Timer
Const Ext$ = "*.txt"
Appelcount = 0 '
countdoss = 0
Table = FSO_List_FICHIERS2(Répertoire, Ext)
If IsArray(Table) Then
Table = TransposeArray(Table)
tim = Format(Timer - tim, "#0.000 S")
MsgBox UBound(Table) & " fichier(s)<""" & Ext & """> trouvé(s) dans le répertoire <" & Répertoire & "> en " & tim & " s/" & _
vbCrLf & "pour " & Appelcount & " appels de la fonction sur dossier et " & countdoss & " dossiers seulement en contiennent "
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_FICHIERS2(ByVal NomRépertoire As Variant, Optional PartName As String = "") As Variant
Static tbl() As String: Static NbFichiers As Long: Static oFSO As Object
Appelcount = Appelcount + 1
countdoss = countdoss + 1
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
Else
InitialCall = True
Erase tbl
NbFichiers = 0
Set oFSO = CreateObject("Scripting.FileSystemObject")
If Right(NomRépertoire, 1) <> "\" Then NomRépertoire = NomRépertoire & "\"
Set oDir = oFSO.getfolder(NomRépertoire)
End If
TakeIT = True
On Error Resume Next
TakeIT = Len(Dir(oDir.Path & "\" & PartName)) > 0
If Err.Number <> 0 Or TakeIT = False Then Err.Clear: countdoss = countdoss - 1: GoSub Scanfolder
For Each oFile In oDir.Files
If Err.Number = 0 Then
If Len(PartName) = 0 Then
NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oFile.Path
Else
If oFile.Name Like PartName Then NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oFile.Path 'Stocke le nom complet du fichier en table
End If
End If
Err.Clear
Next oFile
On Error GoTo 0
Scanfolder:
For Each oSubDir In oDir.subfolders
If Err.Number = 0 Then
FSO_List_FICHIERS2 oSubDir, PartName
Else: Err.Clear
End If
Next oSubDir
On Error GoTo 0
If InitialCall Then
FSO_List_FICHIERS2 = False
If NbFichiers > 0 Then FSO_List_FICHIERS2 = tbl
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
