Lister tous les fichiers d'un dossier et de ses sous-dossiers
source net
Source / Exemple :
Attribute VB_Name = "ListeFichiersEtDossiers"
Option Explicit
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Sub ListFiles()
Dim msg As String, answer As String
Dim Directory As String
Dim R As Integer
Dim i As Integer
Dim StartDate As Single
msg = "Select a location containing the files you want to list."
Directory = GetDirectory(msg)
If Directory = "" Then Exit Sub
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
' Insert headers
R = ActiveCell.Row
Cells(R, 1) = "FilePath"
Cells(R, 2) = "Size"
Cells(R, 3) = "Date/Time"
Cells(R, 4) = "Filename"
Range("A1:C1").Font.Bold = True
R = R + 1
On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = Directory
.Filename = "*.*" ' this can be '*.*
.SearchSubFolders = True
.Execute
For i = 1 To .FoundFiles.Count
If FileDateTime(.FoundFiles(i)) > StartDate Then
Cells(R, 1) = .FoundFiles(i)
Cells(R, 4) = Right(Cells(R, 1), Len(.FoundFiles(i)) - InStrRev(Cells(R, 1).Value, "\"))
Cells(R, 2) = FileLen(.FoundFiles(i))
Cells(R, 3) = FileDateTime(.FoundFiles(i))
R = R + 1
End If
Next i
End With
'Columns("A:C").Select
'Selection.Columns.AutoFit
'ActiveSheet.Columns("1:3").AutoFit
MsgBox "file listing complete"
End Sub
Function GetDirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim R As Long, x As Long, pos As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(msg) Then
bInfo.lpszTitle = "Select a folder"
Else
bInfo.lpszTitle = msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
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
Function InStrLast(iStart As Integer, szSrchIn As String, _
szSrchFor As String, iCompare As Integer) As Integer
Dim iPrevFoundAt As Integer
Dim iFoundAt As Integer
On Error GoTo ErrExit_InStrLast
iPrevFoundAt = 0
iFoundAt = InStr(iStart, szSrchIn, szSrchFor, iCompare)
Do While iFoundAt > 0
iPrevFoundAt = iFoundAt
iFoundAt = InStr(iPrevFoundAt + 1, szSrchIn, szSrchFor, iCompare)
Loop
ErrExit_InStrLast:
If Err <> 0 Then MsgBox Error$, vbExclamation
InStrLast = iPrevFoundAt
Exit Function
End Function
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.