Sub ScanClasseurs()
Dim Dossier As Object, Fichier As Object
Dim Chemin As String, CeFichier As String, ExtFichier As String[COLOR="Red"][B], ExtLongeur As Integer[/B][/COLOR]
Dim TabDossiers As Variant
Dim L As Long, D As Long
Chemin = CheminUser
If Chemin = "" Then Exit Sub
Application.ScreenUpdating = False
ThisWorkbook.Sheets("Test").Range("A2:B65536").Delete Shift:=xlUp
CeFichier = ThisWorkbook.Name
ExtFichier = UCase(Trim(ThisWorkbook.Sheets("Test").Range("Extension").Text))
[COLOR="Red"][B]ExtLongeur = Len(ExtFichier)[/B][/COLOR]
L = 1
'Création du tableau des sous-dossiers existants
TabDossiers = lstDossiers(Chemin, True)
For D = 1 To UBound(TabDossiers)
'Chemin du dossier (ou sous-dossier) à analyser
Chemin = TabDossiers(D)
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
'Analyse du dossier (ou sous-dossier)
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
For Each Fichier In Dossier.Files
If Fichier.Name <> CeFichier Then
If ExtFichier = "" Or UCase(Right(Fichier.Name, 3)) = ExtFichier Then
'Liste les fichiers
L = L + 1
'MAJ feuille résultats
With ThisWorkbook.Sheets("Test")
.Cells(L, 1).Value = Chemin
.Hyperlinks.Add Anchor:=.Cells(L, 2), Address:=Chemin & Fichier.Name, _
TextToDisplay:=[COLOR="Red"][B]Left(Fichier.Name, Len(Fichier.Name) - (ExtLongeur + 1))[/B][/COLOR]
.Cells(L, 3).Value = Fichier.Type
.Cells(L, 4).Value = Fichier.Size
.Cells(L, 5).Value = Fichier.DateCreated
End With
End If
End If
Next
Next D
Set Dossier = Nothing
'Rétablit l'alerte de lien éventuelle dans les options Excel
Application.ScreenUpdating = True
MsgBox L - 1 & " fichiers trouvés !"
End Sub
