LISTER TOUS LES FICHIERS D'UN DOSSIER ET DE SES SOUS-DOSSIERS

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