'===========================
Sub Liste_des_Fichiers()
Dim Msg$, Directory$, Nb%
Dim i As Long, Ext$, Ex$
Dim Dossier As Object
Dim Fichier As Object
Dim Tablo(), Tablo2()
Msg = "Sélectionnez un emplacement contenant les fichiers que vous souhaitez lister."
Directory = GetDirectory(Msg)
If Directory = "" Then Exit Sub
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
'------- Insérer en-têtes ------
i = 2
ActiveSheet.AutoFilterMode = False
Range("A:F").ClearContents
Cells(i, 1) = "Nom de fichier"
Cells(i, 2) = "Taille"
Cells(i, 3) = "Date de création"
Cells(i, 4) = "Date de dernière modification"
Cells(i, 5) = "Type"
With Range("A1:F2")
.Font.Bold = True: Range("C:C").ColumnWidth = 16 ': Exit Sub
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 6: Range("A1").Interior.ColorIndex = 44
End With
On Error Resume Next
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Directory)
'--------- Choix Extention --------
Ex = InputBox("Choix extention :" & Chr(10) & ".xls, .doc, .PDF, .txt, .jpg, .avi, .zip, .gif" _
& Chr(10) & ".bmp, .ico, .mid, .mp3, .wma, .xlsm, .xlsx, .docx" _
& Chr(10) & "Ne pas oublier le point" _
& Chr(10) & "Pour tout lister extention vide --> valider directement", "EXTENTION")
'------- Affichage Fichiers -------
i = 0
For Each Fichier In Dossier.Files
If Fichier.Name Like "*" & Ex Then
i = i + 1
ReDim Preserve Tablo(1 To 5, 1 To i)
Tablo(1, i) = Fichier.Name: Tablo(2, i) = Fichier.Size: Tablo(3, i) = Fichier.datecreated:: Tablo(4, i) = Fichier.datelastmodified: Tablo(5, i) = Fichier.Type
End If
Cells(2, 6) = "Q = " & i - 2
Next Fichier
ReDim Tablo2(LBound(Tablo, 2) To UBound(Tablo, 2), 1 To 5)
For i = LBound(Tablo, 2) To UBound(Tablo, 2)
Tablo2(i, 1) = Tablo(1, i): Tablo2(i, 2) = Tablo(2, i): Tablo2(i, 3) = Tablo(3, i): Tablo2(i, 4) = Tablo(4, i):: Tablo2(i, 5) = Tablo(5, i)
Next i
Range("A3:E" & 3 + UBound(Tablo, 2) - LBound(Tablo, 2)).Value = Tablo2
Range("A1").Value = Directory
Range("A2:E2").AutoFilter
Columns("A:F").EntireColumn.AutoFit
End Sub
'============================
'--> Fonction de Walkenbach
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
'---------- Dossier racine = Bureau ---------
bInfo.pidlRoot = 0&
'------ Titre dans la boîte de dialogue -----
If IsMissing(Msg) Then
bInfo.lpszTitle = "Sélectionnez un dossier."
Else
bInfo.lpszTitle = Msg
End If
'-------- Type de dossier à retourner -------
bInfo.ulFlags = &H1
'------- Afficher la boîte de dialogue ------
x = SHBrowseForFolder(bInfo)
'---------- Afficher le résultat ------------
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
'==========================