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
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
|
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "CollectedFiles"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'/*************************************************************************
' *
' DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
'
' Copyright 2000, 2010 Oracle and/or its affiliates.
'
' OpenOffice.org - a multi-platform office productivity suite
'
' This file is part of OpenOffice.org.
'
' OpenOffice.org is free software: you can redistribute it and/or modify
' it under the terms of the GNU Lesser General Public License version 3
' only, as published by the Free Software Foundation.
'
' OpenOffice.org is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
' GNU Lesser General Public License version 3 for more details
' (a copy is included in the LICENSE file that accompanied this code).
'
' You should have received a copy of the GNU Lesser General Public License
' version 3 along with OpenOffice.org. If not, see
' <http://www.openoffice.org/license.html>
' for a copy of the LGPLv3 License.
'
' ************************************************************************/
Option Explicit
Private Const vbDot = 46
Private Const MAX_PATH = 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
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 'holds search parameters
Private mWordFilesCol As Collection
Private mExcelFilesCol As Collection
Private mPPFilesCol As Collection
Private mDocCount As Long
Private mDotCount As Long
Private mXlsCount As Long
Private mXltCount As Long
Private mPptCount As Long
Private mPotCount As Long
Private mbDocSearch As Boolean
Private mbDotSearch As Boolean
Private mbXlsSearch As Boolean
Private mbXltSearch As Boolean
Private mbPptSearch As Boolean
Private mbPotSearch As Boolean
Private mBannedList As Collection
Private Sub Class_Initialize()
Set mWordFilesCol = New Collection
Set mExcelFilesCol = New Collection
Set mPPFilesCol = New Collection
Set mBannedList = New Collection
End Sub
Private Sub Class_Terminate()
Set mWordFilesCol = Nothing
Set mExcelFilesCol = Nothing
Set mPPFilesCol = Nothing
Set mBannedList = Nothing
End Sub
Public Property Get BannedList() As Collection
Set BannedList = mBannedList
End Property
Public Property Let BannedList(ByVal theList As Collection)
Set mBannedList = theList
End Property
Public Property Get DocCount() As Long
DocCount = mDocCount
End Property
Public Property Get DotCount() As Long
DotCount = mDotCount
End Property
Public Property Get XlsCount() As Long
XlsCount = mXlsCount
End Property
Public Property Get XltCount() As Long
XltCount = mXltCount
End Property
Public Property Get PptCount() As Long
PptCount = mPptCount
End Property
Public Property Get PotCount() As Long
PotCount = mPotCount
End Property
Public Property Get WordFiles() As Collection
Set WordFiles = mWordFilesCol
End Property
Public Property Get ExcelFiles() As Collection
Set ExcelFiles = mExcelFilesCol
End Property
Public Property Get PowerPointFiles() As Collection
Set PowerPointFiles = mPPFilesCol
End Property
Public Function count() As Long
count = mWordFilesCol.count + mExcelFilesCol.count + mPPFilesCol.count
End Function
Public Function Search(rootDir As String, _
FileSpecs As Collection, IncludeSubdirs As Boolean)
On Error GoTo HandleErrors
Dim currentFunctionName As String
currentFunctionName = "Search"
Dim tstart As Single 'timer var for this routine only
Dim tend As Single 'timer var for this routine only
Dim spec As Variant
Dim allSpecs As String
Dim fso As New FileSystemObject
If FileSpecs.count = 0 Then Exit Function
If FileSpecs.count > 1 Then
For Each spec In FileSpecs
allSpecs = allSpecs & "; " & spec
SetSearchBoolean CStr(spec)
Next
Else
allSpecs = FileSpecs(1)
SetSearchBoolean CStr(FileSpecs(1))
End If
With fp
.sFileRoot = QualifyPath(rootDir)
.sFileNameExt = allSpecs
.bRecurse = IncludeSubdirs
.nSearched = 0
End With
tstart = GetTickCount()
Call SearchForFiles(fp.sFileRoot)
tend = GetTickCount()
'Debug:
'MsgBox "Specs " & allSpecs & vbLf & _
' Format$(fp.nSearched, "###,###,###,##0") & vbLf & _
' Format$(count, "###,###,###,##0") & vbLf & _
' FormatNumber((tend - tstart) / 1000, 2) & " seconds"
FinalExit:
Set fso = Nothing
Exit Function
HandleErrors:
WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source
Resume FinalExit
End Function
Function isBannedFile(thePath As String) As Boolean
Dim aPath As Variant
Dim theResult As Boolean
theResult = False
For Each aPath In mBannedList
If aPath = thePath Then
theResult = True
GoTo FinalExit
End If
Next
FinalExit:
isBannedFile = theResult
End Function
Sub SetSearchBoolean(spec As String)
If spec = "*.doc" Then
mbDocSearch = True
End If
If spec = "*.dot" Then
mbDotSearch = True
End If
If spec = "*.xls" Then
mbXlsSearch = True
End If
If spec = "*.xlt" Then
mbXltSearch = True
End If
If spec = "*.ppt" Then
mbPptSearch = True
End If
If spec = "*.pot" Then
mbPotSearch = True
End If
End Sub
Private Sub SearchForFiles(sRoot As String)
On Error GoTo HandleErrors
Dim currentFunctionName As String
currentFunctionName = "SearchForFiles"
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long
Dim path As String
Dim WordDriverPathTemp As String
Dim ExcelDriverPathTemp As String
Dim PPDriverPathTemp As String
hFile = FindFirstFile(sRoot & ALL_FILES, WFD)
If hFile = INVALID_HANDLE_VALUE Then GoTo FinalExit
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..
If mbDocSearch Then
If MatchSpec(WFD.cFileName, "*.doc") Then
path = sRoot & TrimNull(WFD.cFileName)
'If StrComp(path, mWordDriverPath, vbTextCompare) <> 0 Then
If Not isBannedFile(path) Then
mDocCount = mDocCount + 1
mWordFilesCol.Add path
GoTo CONTINUE_LOOP
End If
End If
End If
If mbDotSearch Then
If MatchSpec(WFD.cFileName, "*.dot") Then
mDotCount = mDotCount + 1
mWordFilesCol.Add sRoot & TrimNull(WFD.cFileName)
GoTo CONTINUE_LOOP
End If
End If
If mbXlsSearch Then
If MatchSpec(WFD.cFileName, "*.xls") Then
path = sRoot & TrimNull(WFD.cFileName)
'If StrComp(TrimNull(WFD.cFileName), CEXCEL_DRIVER_FILE, vbTextCompare) <> 0 Then
If Not isBannedFile(path) Then
mXlsCount = mXlsCount + 1
mExcelFilesCol.Add sRoot & TrimNull(WFD.cFileName)
GoTo CONTINUE_LOOP
End If
End If
End If
If mbXltSearch Then
If MatchSpec(WFD.cFileName, "*.xlt") Then
mXltCount = mXltCount + 1
mExcelFilesCol.Add sRoot & TrimNull(WFD.cFileName)
GoTo CONTINUE_LOOP
End If
End If
If mbPptSearch Then
If MatchSpec(WFD.cFileName, "*.ppt") Then
path = sRoot & TrimNull(WFD.cFileName)
'If StrComp(path, mPPDriverPath, vbTextCompare) <> 0 Then
If Not isBannedFile(path) Then
mPptCount = mPptCount + 1
mPPFilesCol.Add path
GoTo CONTINUE_LOOP
End If
End If
End If
If mbPotSearch Then
If MatchSpec(WFD.cFileName, "*.pot") Then
mPotCount = mPotCount + 1
mPPFilesCol.Add sRoot & TrimNull(WFD.cFileName)
GoTo CONTINUE_LOOP
End If
End If
End If 'If WFD.dwFileAttributes
CONTINUE_LOOP:
fp.nSearched = fp.nSearched + 1
Loop While FindNextFile(hFile, WFD)
FinalExit:
Call FindClose(hFile)
Exit Sub
HandleErrors:
WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source
Resume FinalExit
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))
End Function
|