1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
| 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 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
Dim NbDossiers As Long
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)
NbDossiers = 0
End If
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) = "ALL_FILES"
.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 = 0
End With
QueryPerformanceCounter Debut
SearchForFiles fp.sFileRoot
QueryPerformanceCounter Fin
QueryPerformanceFrequency Freq
With ShDatas
.Cells(3, 1) = Format$(fp.nSearched, "###,###,###,##0")
.Cells(4, 1) = NbDossiers & " // " & Format$(fp.nCount, "###,###,###,##0")
.Cells(5, 1) = FormatNumber((Fin - Debut) / Freq, 2) & " s"
.Range("A1:A5").HorizontalAlignment = xlLeft
.Range("B2").Select
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
NbDossiers = NbDossiers + 1
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)
Application.StatusBar = NbDossiers & " / " & fp.nCount
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 |
Partager