Equivalent de .Filesearch pour recherche de dossiers

Option Explicit

Private Const RDepart = 5
Private Const vbDot = 46
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const vbBackslash = "\"
Private Const ALL_FILES = "*.*"

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private 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

Private Type FILE_PARAMS
    bRecurse As Boolean
    bFindOrExclude As Long
    nCount As Long
    nSearched As Long
    sFileNameExt As String
    sFileRoot As String
End Type

Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" _
                                       Alias "FindFirstFileA" _
                                       (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" _
                                      Alias "FindNextFileA" _
                                      (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function PathMatchSpec Lib "shlwapi" _
                                       Alias "PathMatchSpecW" _
                                       (ByVal pszFileParam As Long, ByVal pszSpec As Long) As Long

Private fp As FILE_PARAMS

Private Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean

Sub SelDossierRacine()
Dim sChemin As String
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner le Dossier Racine"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then Rch .SelectedItems(1)
    End With
End Sub

Private Sub Rch(sRacine As String)
Dim Debut As Currency, Fin As Currency, Freq As Currency

    With ShDatas
        .Cells.Clear
        .Cells(1, 1) = sRacine
        
        .Cells(2, 1) = "*.xls"
        
        .Cells(3, 1) = ""
        .Cells(4, 1) = ""
        .Cells(5, 1) = ""
        .Range("B:B").Clear
    End With
    
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1
    
    Application.ScreenUpdating = False
    With fp
        '   start path
        .sFileRoot = QualifyPath(ShDatas.Cells(1, 1))
        '   file type(s) of interest
        .sFileNameExt = ShDatas.Cells(2, 1)
        .bRecurse = True
        .nCount = 0
        .nSearched = 0

        '   0=include, 1=exclude
        .bFindOrExclude = 1
    End With

    QueryPerformanceCounter Debut
    SearchForFiles fp.sFileRoot
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq

    With ShDatas
        .Cells(3, 1) = Format$(fp.nSearched, "###,###,###,##0")
        .Cells(4, 1) = Format$(fp.nCount, "###,###,###,##0")
        .Cells(5, 1) = FormatNumber((Fin - Debut) / Freq, 5) & " s"
        
        .Range("A1:A5").HorizontalAlignment = xlLeft
    End With
    
    Application.ScreenUpdating = True
End Sub

Private Sub SearchForFiles(sRoot As String)
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long
    hFile = FindFirstFile(sRoot & ALL_FILES, WFD)
    If hFile <> INVALID_HANDLE_VALUE Then
        Do
            '   if a folder, and recurse specified, call method again
            If (WFD.dwFileAttributes And vbDirectory) Then
                If Asc(WFD.cFileName) <> vbDot Then
                    If fp.bRecurse Then SearchForFiles sRoot & TrimNull(WFD.cFileName) & vbBackslash
                End If
            Else
                '   must be a file ..
                If MatchSpec(WFD.cFileName, fp.sFileNameExt) Then
                    fp.nCount = fp.nCount + 1
                    ShDatas.Cells(fp.nCount + RDepart, 2) = sRoot & TrimNull(WFD.cFileName)
                End If
            End If
            fp.nSearched = fp.nSearched + 1
        Loop While FindNextFile(hFile, WFD)
    End If
    FindClose hFile
End Sub

Private Function QualifyPath(sPath As String) As String
    If Right$(sPath, 1) <> vbBackslash Then
        QualifyPath = sPath & vbBackslash
    Else
        QualifyPath = sPath
    End If
End Function

Private Function TrimNull(startstr As String) As String
    TrimNull = Left$(startstr, lstrlen(StrPtr(startstr)))
End Function

Private Function MatchSpec(sFile As String, sSpec As String) As Boolean
    MatchSpec = PathMatchSpec(StrPtr(sFile), StrPtr(sSpec)) = fp.bFindOrExclude
End Function