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
