Sub ScanClasseurs()
'ATTENTION : nécessite une référence à la librairie
'Microsoft Visual Basic For Applications Extensibility 5.3
Dim Dossier As Object, Fichier As Object
Dim Chemin As String, CeFichier As String
Dim TabDossiers As Variant
Dim L As Long, D As Long
Application.ScreenUpdating = False
ThisWorkbook.Sheets('Test').Range('A2:B65536').ClearContents
CeFichier = ThisWorkbook.Name
L = 1
'Création du tableau des sous-dossiers existants
TabDossiers = lstDossiers(ThisWorkbook.Path, True)
For D = 1 To UBound(TabDossiers)
'Chemin du dossier (ou sous-dossier) à analyser
Chemin = TabDossiers(D) & '\'
'Analyse du dossier (ou sous-dossier)
Set Dossier = CreateObject('Scripting.FileSystemObject').GetFolder(Chemin)
For Each Fichier In Dossier.Files
If Fichier.Name <> CeFichier Then
'Liste les fichiers Excel
If Right(Fichier.Name, 3) = 'xls' Then
L = L + 1
'MAJ feuille Excel
With ThisWorkbook.Sheets('Test')
.Cells(L, 1) = Chemin
.Cells(L, 2) = Fichier.Name
End With
'MAJ liste Usf
usfScan.lstClasseurs.AddItem Chemin & Fichier.Name
End If
End If
Next
Next D
Set Dossier = Nothing
'Rétablit l'alerte de lien éventuelle dans les options Excel
Application.ScreenUpdating = True
usfScan.lblCompteur = L - 1 & ' classeurs trouvés !'
usfScan.Show
End Sub
Private Function lstDossiers(Chemin As String, Optional Debut As Boolean) As Variant
Dim Dossier As Object, SD As Object, D As Object
Static TabTemp() As String
If Debut Then
ReDim TabTemp(1 To 1)
TabTemp(1) = Chemin
End If
Set Dossier = CreateObject('Scripting.FileSystemObject').GetFolder(Chemin)
'examen du dossier courant
For Each D In Dossier.subfolders
ReDim Preserve TabTemp(1 To UBound(TabTemp) + 1)
TabTemp(UBound(TabTemp)) = D.Path
Next
'Traitement récursif des sous-dossiers (d'après un code de F.Sigonneau)
For Each SD In Dossier.subfolders
lstDossiers SD.Path
Next SD
lstDossiers = TabTemp()
Set Dossier = Nothing
End Function