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 |
Numériser des documents au format PDF sous VBA excel
Répondre avec citation
Partager