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 161 162 163
| Option Explicit
'recherche de fichiers avec les fonctions API (rapide, récursif)
'code à étudier :-)
'code : Randy Birch/RB Smissaert (mpep)
'http://www.mvps.org/vbnet/index.html?code/fileapi/recursivefolders_minimal.htm
Private Const vbDot = 46
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const vbBackslash = "\"
Private Const ALL_FILES = "*.*"
Private fp As FILE_PARAMS 'holds search parameters
Private List1(1000, 0) As String
Private i As Long
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 '1=find matching, 0=exclude matching
nCount As Long
nSearched As Long
sFileNameExt As String
sFileRoot As String
End Type
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 FindClose Lib "kernel32" _
(ByVal hFindFile As Long) 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
Sub Start() 'recherche fichier
Dim hFile As Long
Dim WFD As WIN32_FIND_DATA
Dim FolderName As String
Dim filename As String
Dim n As Long
Dim temps, count
Dim scan As String
On Error Resume Next
Sheets("Feuil1").Select 'choix feuille
If [A1] = "" Then
scan = InputBox("Entrez le nom de l'exe du scan" & Chr(10) & " Veuillez patienter ensuite pendant la recherche", "Scanner", "HP Photosmart 5510 series.exe")
temps = Timer ' Timer pour calculer la durée de la recherche
FolderName = "C:\" 'Répertoire
If FolderName = "" Then
Exit Sub
End If
filename = scan 'nom Fichier exe scan
If filename = "" Then
Exit Sub
End If
i = 0
Erase List1
With fp
.sFileRoot = QualifyPath(FolderName) 'start path
.sFileNameExt = filename 'file type(s) of interest
.bRecurse = True 'True = recursive search
.nCount = 0 'results
.nSearched = 0 'results
.bFindOrExclude = 1 '1 = find, 0 = exclude
End With
Call SearchForFiles(fp.sFileRoot)
If i = 0 Then
MsgBox filename & " non trouvé, vérifiez l'orthographe.", , " Conclusion du dossier"
Else
For n = 0 To i - 1
count = i 'On compte les fichiers
With ActiveSheet("Feuil1")
[A1] = List1(n, 0) 'on inscrit le chemin du fichier sur la feuille Excel
Application.StatusBar = "Trouvé " & count & " fichier(s) " & filename & " en " & Timer - temps & " secondes."
End With
Next
MsgBox "Trouvé " & count & " fichier(s) " & filename & " en " & Timer - temps & " secondes.", , " Conclusion du dossier"
End If
End If
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
End If
Else
'must be a file and not the open temp file (~$....)
If MatchSpec(WFD.cFileName, fp.sFileNameExt) And Not _
Left$(WFD.cFileName, 2) = "~$" Then
fp.nCount = fp.nCount + 1
List1(i, 0) = sRoot & TrimNull(WFD.cFileName)
i = i + 1
End If
End If
Loop While FindNextFile(hFile, WFD)
End If
Call 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