'-----------------------------------------------------------------------------------
'  Cocher dans Outils References Microsoft Scripting Runtime
'-----------------------------------------------------------------------------------
 
Option Explicit
 
Public Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Public Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
 
Dim Cpt As Long, Nb As Long
'   Const TypeFichier As String = "##.xls"
'   Const TypeFichier As String = "trans_###_########.txt"
Const TypeFichier As String = "*.*"
 
Private Sub Lire(sChemin As String)
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim Dico As Scripting.Dictionary
 
    Set Dico = New Scripting.Dictionary
     
    Application.ScreenUpdating = False
    QueryPerformanceCounter Dep
     
    ListeFichiers sChemin, Dico, True
             
    With ShDatas
        .Cells.Clear
        .Range("A1:A" & Dico.Count) = Application.Transpose(Dico.Items)
        .Range("B1" ).Select
    End With
     
    Set Dico = Nothing
     
    QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
    With Application
        .StatusBar = "Terminé : " & Cpt & " / " & Nb & " / " & Format(((Fin - Dep) / Freq), "0.00 s" )
        .ScreenUpdating = True
    End With
End Sub
 
Private Sub ListeFichiers(sChemin As String, Dico As Dictionary, Recursif As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim Dossier As Scripting.Folder
Dim SousDossier As Scripting.Folder
Dim Fichier As Scripting.File
     
    Set FSO = New Scripting.FileSystemObject
    Set Dossier = FSO.GetFolder(sChemin)
 
    For Each Fichier In Dossier.Files
        Nb = Nb + 1
        If UCase(Fichier.Name) Like UCase(TypeFichier) Then
            Cpt = Cpt + 1
            Dico.Add Fichier.Path, Fichier.Path
            Application.StatusBar = Cpt & " / " & Nb
        End If
    Next Fichier
     
    If Recursif Then
        For Each SousDossier In Dossier.SubFolders
            ListeFichiers SousDossier.Path, Dico, True
        Next SousDossier
    End If
     
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub
 
Sub Tst()
Dim sChemin As String
 
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner un Dossier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            Cpt = 0: Nb = 0
            Application.StatusBar = ""
            DoEvents
            Lire .SelectedItems(1)
        End If
    End With
End Sub

Option Explicit
 
Declare Function FindFirstFile Lib "Kernel32" Alias _
                               "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData _
                                                                             As WIN32_FIND_DATA) As Long
 
Declare Function FindNextFile Lib "Kernel32" Alias "FindNextFileA" _
                              (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
 
Declare Function GetFileAttributes Lib "Kernel32" Alias _
                                   "GetFileAttributesA" (ByVal lpFileName As String) As Long
 
Declare Function FindClose Lib "Kernel32" (ByVal hFindFile As Long) As Long
 
Declare Function FileTimeToLocalFileTime Lib "Kernel32" _
                                         (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
 
Declare Function FileTimeToSystemTime Lib "Kernel32" _
                                      (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
 
Declare Function SHGetFileInfo Lib "shell32" _
                               Alias "SHGetFileInfoA" _
                               (ByVal pszPath As String, _
                                ByVal dwFileAttributes As Long, _
                                psfi As SHFILEINFO, _
                                ByVal cbSizeFileInfo As Long, _
                                ByVal uFlags As Long) As Long
 
Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
 
Public Const MAX_PATH = 260
Public Const MAXDWORD = &HFFFF
Public Const INVALID_HANDLE_VALUE As Long = -1
Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
Public Const FILE_ATTRIBUTE_HIDDEN = &H2
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const FILE_ATTRIBUTE_READONLY = &H1
Public Const FILE_ATTRIBUTE_SYSTEM = &H4
Public Const FILE_ATTRIBUTE_TEMPORARY = &H100
Public Const SHGFI_TYPENAME As Long = &H400
 
Type SHFILEINFO
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
End Type
 
Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type
 
Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type
 
Public Function StripNulls(OriginalStr As String) As String
    If (InStr(OriginalStr, Chr(0)) > 0) Then
        OriginalStr = Left(OriginalStr, _
                           InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
End Function

Option Explicit
 
Const FindStr As String = "*.xls"
 
Dim NumFiles As Long, NumDirs As Long
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim r As Long, Vers As Integer
 
Private Function FindFilesAPI(ByVal path As String, ByVal SearchStr As String, ByRef FileCount As Long, ByRef DirCount As Long)
Dim FileName As String
Dim DirName As String
Dim dirNames() As String
Dim nDir As Long
Dim i As Long
Dim hFile As Long
Dim WFD As WIN32_FIND_DATA
Dim Cont As Boolean
Dim sPath As String
 
    If Right(path, 1) <> "\" Then path = path & "\"
    nDir = 0
    ReDim dirNames(nDir)
    Cont = True
 
    sPath = path & "*.*"
 
    hFile = FindFirstFile(sPath, WFD)
    If hFile <> INVALID_HANDLE_VALUE Then
        Do While Cont
            DirName = StripNulls(WFD.cFileName)
 
            If (DirName <> "." ) And (DirName <> ".." ) Then
 
                If GetFileAttributes(path & DirName) And FILE_ATTRIBUTE_DIRECTORY Then
                    dirNames(nDir) = DirName
                    DirCount = DirCount + 1
                    nDir = nDir + 1
                    ReDim Preserve dirNames(nDir)
 
                    Application.StatusBar = "Fichiers : " & NumFiles & " / Dossiers : " & NumDirs
                End If
            End If
            Cont = FindNextFile(hFile, WFD)
        Loop
        Cont = FindClose(hFile)
    End If
 
    hFile = FindFirstFile(path & SearchStr, WFD)
    Cont = True
    If hFile <> INVALID_HANDLE_VALUE Then
        While Cont
            FileName = StripNulls(WFD.cFileName)
            If (FileName <> "." ) And (FileName <> ".." ) And _
               ((GetFileAttributes(path & FileName) And _
                 FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY) Then
 
                FindFilesAPI = FindFilesAPI + (WFD.nFileSizeHigh * MAXDWORD) + WFD.nFileSizeLow
                FileCount = FileCount + 1
 
                r = r + 1
                If Vers < 12 Then
                    If r > 65536 Then
                        r = 1
                        Sheets.Add
                    End If
                End If
                With ActiveSheet
                    .Cells(r, 1) = path
                    .Cells(r, 2) = FileName
                End With
                Application.StatusBar = "Fichiers : " & NumFiles & " / Dossiers : " & NumDirs
            End If
            Cont = FindNextFile(hFile, WFD)
        Wend
        Cont = FindClose(hFile)
    End If
 
    If nDir > 0 Then
        For i = 0 To nDir - 1
            FindFilesAPI = FindFilesAPI + FindFilesAPI(path & dirNames(i) & "\", SearchStr, FileCount, DirCount)
        Next i
    End If
End Function
 
Private Sub Lire(ByVal sPath As String)
    ShFichiers.Range("A2:IV" & Rows.Count).Clear
    Application.ScreenUpdating = False
 
    FindFilesAPI sPath, FindStr, NumFiles, NumDirs
     
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
    Application.ScreenUpdating = True
End Sub
 
Sub Tst()
Dim sChemin As String
    Vers = Val(Application.Version)
    sChemin = ThisWorkbook.path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner un Dossier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            r = 1: NumFiles = 0: NumDirs = 0
            Application.StatusBar = ""
            DoEvents
            QueryPerformanceCounter Dep
             
            Lire .SelectedItems(1)
             
            QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
            Application.StatusBar = "Fichiers : " & NumFiles & " / Dossiers : " & NumDirs & " / " & Format(((Fin - Dep) / Freq), "0.00 s" )
        End If
    End With
End Sub

Option Explicit
 
Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
 
Dim NbFichiers As Long, NbDossiers As Long
Dim Dep As Currency, Fin As Currency, Freq As Currency
 
Private Sub Lire(ByVal sChemin As String, ByVal Recursif As Boolean)
Dim FSO As Object, Dossier As Object, Fichier As String
    Set FSO = CreateObject("Scripting.FileSystemObject" )
    Set Dossier = FSO.GetFolder(sChemin)
 
    Fichier = Dir$(sChemin & "\*.*" )
    Do While Len(Fichier) > 0
        NbFichiers = NbFichiers + 1
        With ShFichiers
            .Cells(NbFichiers, 1) = sChemin
            .Cells(NbFichiers, 2) = Fichier
        End With
        Fichier = Dir$()
        Application.StatusBar = "Fichiers : " & NbFichiers & " Dossiers : " & NbDossiers
    Loop
 
    If Recursif Then
        For Each Dossier In Dossier.SubFolders
            NbDossiers = NbDossiers + 1
            Lire Dossier.Path, True
        Next Dossier
    End If
 
    Set FSO = Nothing
End Sub
 
Sub Tst()
Dim sChemin As String
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner un Dossier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            ShFichiers.Cells.Clear
            Application.ScreenUpdating = False
            Application.StatusBar = ""
            DoEvents
            QueryPerformanceCounter Dep
            NbFichiers = 0: NbDossiers = 0
 
            Lire .SelectedItems(1), True
 
            Application.ScreenUpdating = True
            QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
            Application.StatusBar = "Fichiers : " & NbFichiers & " / Dossiers : " & NbDossiers & " / " & Format(((Fin - Dep) / Freq), "0.00 s" )
        End If
    End With
End Sub