1VERSION 1.0 CLASS 2BEGIN 3 MultiUse = -1 'True 4 Persistable = 0 'NotPersistable 5 DataBindingBehavior = 0 'vbNone 6 DataSourceBehavior = 0 'vbNone 7 MTSTransactionMode = 0 'NotAnMTSObject 8END 9Attribute VB_Name = "CollectedFiles" 10Attribute VB_GlobalNameSpace = False 11Attribute VB_Creatable = True 12Attribute VB_PredeclaredId = False 13Attribute VB_Exposed = False 14'************************************************************************* 15' 16' Licensed to the Apache Software Foundation (ASF) under one 17' or more contributor license agreements. See the NOTICE file 18' distributed with this work for additional information 19' regarding copyright ownership. The ASF licenses this file 20' to you under the Apache License, Version 2.0 (the 21' "License"); you may not use this file except in compliance 22' with the License. You may obtain a copy of the License at 23' 24' http://www.apache.org/licenses/LICENSE-2.0 25' 26' Unless required by applicable law or agreed to in writing, 27' software distributed under the License is distributed on an 28' "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY 29' KIND, either express or implied. See the License for the 30' specific language governing permissions and limitations 31' under the License. 32' 33'************************************************************************* 34Option Explicit 35 36Private Const vbDot = 46 37Private Const MAX_PATH = 260 38Private Const INVALID_HANDLE_VALUE = -1 39Private Const vbBackslash = "\" 40Private Const ALL_FILES = "*.*" 41 42Private Type FILETIME 43 dwLowDateTime As Long 44 dwHighDateTime As Long 45End Type 46 47Private Type SYSTEMTIME 48 wYear As Integer 49 wMonth As Integer 50 wDayOfWeek As Integer 51 wDay As Integer 52 wHour As Integer 53 wMinute As Integer 54 wSecond As Integer 55 wMilliseconds As Integer 56End Type 57 58Private Type WIN32_FIND_DATA 59 dwFileAttributes As Long 60 ftCreationTime As FILETIME 61 ftLastAccessTime As FILETIME 62 ftLastWriteTime As FILETIME 63 nFileSizeHigh As Long 64 nFileSizeLow As Long 65 dwReserved0 As Long 66 dwReserved1 As Long 67 cFileName As String * MAX_PATH 68 cAlternate As String * 14 69End Type 70 71Private Type FILE_PARAMS 72 bRecurse As Boolean 73 nSearched As Long 74 sFileNameExt As String 75 sFileRoot As String 76End Type 77 78Private Declare Function SystemTimeToFileTime Lib "kernel32" _ 79 (lpSystemTime As SYSTEMTIME, _ 80 lpFileTime As FILETIME) As Long 81 82Private Declare Function CompareFileTime Lib "kernel32" _ 83 (lpFileTime1 As FILETIME, _ 84 lpFileTime2 As FILETIME) As Long 85 86Private Declare Function FindClose Lib "kernel32" _ 87 (ByVal hFindFile As Long) As Long 88 89Private Declare Function FindFirstFile Lib "kernel32" _ 90 Alias "FindFirstFileA" _ 91 (ByVal lpFileName As String, _ 92 lpFindFileData As WIN32_FIND_DATA) As Long 93 94Private Declare Function FindNextFile Lib "kernel32" _ 95 Alias "FindNextFileA" _ 96 (ByVal hFindFile As Long, _ 97 lpFindFileData As WIN32_FIND_DATA) As Long 98 99Private Declare Function GetTickCount Lib "kernel32" () As Long 100 101Private Declare Function lstrlen Lib "kernel32" _ 102 Alias "lstrlenW" (ByVal lpString As Long) As Long 103 104Private Declare Function PathMatchSpec Lib "shlwapi" _ 105 Alias "PathMatchSpecW" _ 106 (ByVal pszFileParam As Long, _ 107 ByVal pszSpec As Long) As Long 108 109Private fp As FILE_PARAMS 'holds search parameters 110 111Private mWordFilesCol As Collection 112Private mExcelFilesCol As Collection 113Private mPPFilesCol As Collection 114 115Private mLessThan3 As Long 116Private mLessThan6 As Long 117Private mLessThan12 As Long 118Private mMoreThan12 As Long 119Private m3Months As FILETIME 120Private m6Months As FILETIME 121Private m12Months As FILETIME 122 123Private mDocCount As Long 124Private mDotCount As Long 125Private mXlsCount As Long 126Private mXltCount As Long 127Private mPptCount As Long 128Private mPotCount As Long 129Private mIgnoredDocs As Long 130Private mbDocSearch As Boolean 131Private mbDotSearch As Boolean 132Private mbXlsSearch As Boolean 133Private mbXltSearch As Boolean 134Private mbPptSearch As Boolean 135Private mbPotSearch As Boolean 136 137Private mWordDriverPath As String 138Private mExcelDriverPath As String 139Private mPPDriverPath As String 140 141Private Sub Class_Initialize() 142 Set mWordFilesCol = New Collection 143 Set mExcelFilesCol = New Collection 144 Set mPPFilesCol = New Collection 145End Sub 146Private Sub Class_Terminate() 147 Set mWordFilesCol = Nothing 148 Set mExcelFilesCol = Nothing 149 Set mPPFilesCol = Nothing 150End Sub 151 152Public Property Get DocCount() As Long 153 DocCount = mDocCount 154End Property 155Public Property Get DotCount() As Long 156 DotCount = mDotCount 157End Property 158Public Property Get XlsCount() As Long 159 XlsCount = mXlsCount 160End Property 161Public Property Get XltCount() As Long 162 XltCount = mXltCount 163End Property 164Public Property Get PptCount() As Long 165 PptCount = mPptCount 166End Property 167Public Property Get PotCount() As Long 168 PotCount = mPotCount 169End Property 170Public Property Get IgnoredDocCount() As Long 171 IgnoredDocCount = mIgnoredDocs 172End Property 173Public Property Get DocsLessThan3Months() As Long 174 DocsLessThan3Months = mLessThan3 175End Property 176Public Property Get DocsLessThan6Months() As Long 177 DocsLessThan6Months = mLessThan6 178End Property 179Public Property Get DocsLessThan12Months() As Long 180 DocsLessThan12Months = mLessThan12 181End Property 182Public Property Get DocsMoreThan12Months() As Long 183 DocsMoreThan12Months = mMoreThan12 184End Property 185 186Public Property Get WordFiles() As Collection 187 Set WordFiles = mWordFilesCol 188End Property 189Public Property Get ExcelFiles() As Collection 190 Set ExcelFiles = mExcelFilesCol 191End Property 192Public Property Get PowerPointFiles() As Collection 193 Set PowerPointFiles = mPPFilesCol 194End Property 195 196Public Function count() As Long 197 count = mWordFilesCol.count + mExcelFilesCol.count + mPPFilesCol.count 198End Function 199 200Public Function Search(rootDir As String, FileSpecs As Collection, IncludeSubdirs As Boolean, _ 201 ignoreOld As Boolean, Months As Integer) As Boolean 202 On Error GoTo HandleErrors 203 Dim currentFunctionName As String 204 currentFunctionName = "Search" 205 206 Dim tstart As Single 'timer var for this routine only 207 Dim tend As Single 'timer var for this routine only 208 Dim spec As Variant 209 Dim allSpecs As String 210 Dim fso As New FileSystemObject 211 212 Search = True 213 214 If FileSpecs.count = 0 Then Exit Function 215 216 If FileSpecs.count > 1 Then 217 For Each spec In FileSpecs 218 allSpecs = allSpecs & "; " & spec 219 SetSearchBoolean CStr(spec) 220 Next 221 Else 222 allSpecs = FileSpecs(1) 223 SetSearchBoolean CStr(FileSpecs(1)) 224 End If 225 226 mWordDriverPath = fso.GetAbsolutePathName(CBASE_RESOURCE_DIR & "\" & CWORD_DRIVER_FILE) 227 mExcelDriverPath = fso.GetAbsolutePathName(CBASE_RESOURCE_DIR & "\" & CEXCEL_DRIVER_FILE) 228 mPPDriverPath = fso.GetAbsolutePathName(CBASE_RESOURCE_DIR & "\" & CPP_DRIVER_FILE) 229 230 With fp 231 .sFileRoot = QualifyPath(rootDir) 232 .sFileNameExt = allSpecs 233 .bRecurse = IncludeSubdirs 234 .nSearched = 0 235 End With 236 237 Load SearchDocs 238 239 ignoreOld = ignoreOld And InitFileTimes 240 241 Dim limDate As FILETIME 242 If ignoreOld Then 243 If Months = 3 Then 244 limDate = m3Months 245 ElseIf Months = 6 Then 246 limDate = m6Months 247 ElseIf Months = 12 Then 248 limDate = m12Months 249 Else 250 ignoreOld = False 251 End If 252 End If 253 254 'tstart = GetTickCount() 255 Search = SearchForFiles(QualifyPath(rootDir), IncludeSubdirs, ignoreOld, limDate) 256 'tend = GetTickCount() 257 258 Unload SearchDocs 259 260 'Debug: 261 'MsgBox "Specs " & allSpecs & vbLf & _ 262 ' Format$(fp.nSearched, "###,###,###,##0") & vbLf & _ 263 ' Format$(count, "###,###,###,##0") & vbLf & _ 264 ' FormatNumber((tend - tstart) / 1000, 2) & " seconds" 265 266FinalExit: 267 Set fso = Nothing 268 Exit Function 269 270HandleErrors: 271 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 272 Resume FinalExit 273End Function 274Sub SetSearchBoolean(spec As String) 275 276 If spec = "*.doc" Then 277 mbDocSearch = True 278 End If 279 If spec = "*.dot" Then 280 mbDotSearch = True 281 End If 282 If spec = "*.xls" Then 283 mbXlsSearch = True 284 End If 285 If spec = "*.xlt" Then 286 mbXltSearch = True 287 End If 288 If spec = "*.ppt" Then 289 mbPptSearch = True 290 End If 291 If spec = "*.pot" Then 292 mbPotSearch = True 293 End If 294 295End Sub 296 297Private Function SearchForFiles(sRoot As String, bRecurse As Boolean, _ 298 bIgnoreOld As Boolean, limDate As FILETIME) As Boolean 299 On Error GoTo HandleErrors 300 Dim currentFunctionName As String 301 currentFunctionName = "SearchForFiles" 302 303 Dim WFD As WIN32_FIND_DATA 304 Dim hFile As Long 305 Dim path As String 306 Dim sFileName As String 307 Dim nTotal As Long 308 309 SearchForFiles = False 310 311 hFile = FindFirstFile(sRoot & ALL_FILES, WFD) 312 313 If hFile = INVALID_HANDLE_VALUE Then GoTo FinalExit 314 315 Do 316 If (SearchDocs.g_SD_Abort) Then GoTo FinalExit 317 sFileName = TrimNull(WFD.cFileName) 318 'if a folder, and recurse specified, call 319 'method again 320 If (WFD.dwFileAttributes And vbDirectory) Then 321 If (Asc(WFD.cFileName) <> vbDot) And bRecurse Then 322 SearchForFiles sRoot & sFileName & vbBackslash, bRecurse, bIgnoreOld, limDate 323 End If 324 Else 325 'must be a file.. 326 nTotal = mDocCount + mDotCount + mXlsCount + _ 327 mXltCount + mPptCount + mPotCount 328 SearchDocs.SD_UpdateProgress str$(nTotal), sRoot 329 DoEvents 330 331 If mbDocSearch Then 332 If MatchSpec(WFD.cFileName, "*.doc") Then 333 path = sRoot & sFileName 334 335 'If StrComp(path, mWordDriverPath, vbTextCompare) <> 0 Then 336 If Not MatchSpec(path, mWordDriverPath) Then 337 If (IsTooOld(WFD, limDate, bIgnoreOld)) Then 338 mIgnoredDocs = mIgnoredDocs + 1 339 Else 340 mDocCount = mDocCount + 1 341 mWordFilesCol.add path 342 End If 343 End If 344 GoTo CONTINUE_LOOP 345 End If 346 End If 347 If mbDotSearch Then 348 If MatchSpec(WFD.cFileName, "*.dot") Then 349 If (IsTooOld(WFD, limDate, bIgnoreOld)) Then 350 mIgnoredDocs = mIgnoredDocs + 1 351 Else 352 mDotCount = mDotCount + 1 353 mWordFilesCol.add sRoot & sFileName 354 End If 355 GoTo CONTINUE_LOOP 356 End If 357 End If 358 If mbXlsSearch Then 359 If MatchSpec(WFD.cFileName, "*.xls") Then 360 'If StrComp(sFileName, CEXCEL_DRIVER_FILE, vbTextCompare) <> 0 Then 361 If Not MatchSpec(WFD.cFileName, CEXCEL_DRIVER_FILE) Then 362 If (IsTooOld(WFD, limDate, bIgnoreOld)) Then 363 mIgnoredDocs = mIgnoredDocs + 1 364 Else 365 mXlsCount = mXlsCount + 1 366 mExcelFilesCol.add sRoot & sFileName 367 End If 368 End If 369 GoTo CONTINUE_LOOP 370 End If 371 End If 372 If mbXltSearch Then 373 If MatchSpec(WFD.cFileName, "*.xlt") Then 374 If (IsTooOld(WFD, limDate, bIgnoreOld)) Then 375 mIgnoredDocs = mIgnoredDocs + 1 376 Else 377 mXltCount = mXltCount + 1 378 mExcelFilesCol.add sRoot & sFileName 379 End If 380 GoTo CONTINUE_LOOP 381 End If 382 End If 383 If mbPptSearch Then 384 If MatchSpec(WFD.cFileName, "*.ppt") Then 385 path = sRoot & sFileName 386 'If StrComp(path, mPPDriverPath, vbTextCompare) <> 0 Then 387 If Not MatchSpec(path, mPPDriverPath) Then 388 If (IsTooOld(WFD, limDate, bIgnoreOld)) Then 389 mIgnoredDocs = mIgnoredDocs + 1 390 Else 391 mPptCount = mPptCount + 1 392 mPPFilesCol.add path 393 End If 394 End If 395 GoTo CONTINUE_LOOP 396 End If 397 End If 398 If mbPotSearch Then 399 If MatchSpec(WFD.cFileName, "*.pot") Then 400 If (IsTooOld(WFD, limDate, bIgnoreOld)) Then 401 mIgnoredDocs = mIgnoredDocs + 1 402 Else 403 mPotCount = mPotCount + 1 404 mPPFilesCol.add sRoot & sFileName 405 End If 406 GoTo CONTINUE_LOOP 407 End If 408 End If 409 410 End If 'If WFD.dwFileAttributes 411 412CONTINUE_LOOP: 413 fp.nSearched = fp.nSearched + 1 414 415 Loop While FindNextFile(hFile, WFD) 416 417 SearchForFiles = True 418FinalExit: 419 Call FindClose(hFile) 420 Exit Function 421 422HandleErrors: 423 WriteDebug currentFunctionName & " : " & Err.Number & " " & Err.Description & " " & Err.Source 424 Resume FinalExit 425End Function 426 427Private Function QualifyPath(sPath As String) As String 428 429 If Right$(sPath, 1) <> vbBackslash Then 430 QualifyPath = sPath & vbBackslash 431 Else: QualifyPath = sPath 432 End If 433 434End Function 435 436Private Function TrimNull(startstr As String) As String 437 438 TrimNull = Left$(startstr, lstrlen(StrPtr(startstr))) 439 440End Function 441 442Private Function MatchSpec(sFile As String, sSpec As String) As Boolean 443 444 MatchSpec = PathMatchSpec(StrPtr(sFile), StrPtr(sSpec)) 445 446End Function 447 448Private Function IsTooOld(aWFD As WIN32_FIND_DATA, minDate As FILETIME, _ 449 ignoreOld As Boolean) As Boolean 450 451 IsTooOld = False 452 453 Dim aFileTime As FILETIME 454 455 If (aWFD.ftLastWriteTime.dwHighDateTime <> 0) Then 456 aFileTime = aWFD.ftLastWriteTime 457 ElseIf (aWFD.ftCreationTime.dwHighDateTime <> 0) Then 458 aFileTime = aWFD.ftCreationTime 459 Else 460 ' No valid time found, don't ignore file 461 mLessThan3 = mLessThan3 + 1 462 Exit Function 463 End If 464 465 If (ignoreOld) Then 466 If (CompareFileTime(aFileTime, minDate) < 0) Then 467 IsTooOld = True 468 End If 469 End If 470 471 If (CompareFileTime(aWFD.ftLastWriteTime, m12Months) < 0) Then 472 mMoreThan12 = mMoreThan12 + 1 473 ElseIf (CompareFileTime(aWFD.ftLastWriteTime, m6Months) < 0) Then 474 mLessThan12 = mLessThan12 + 1 475 ElseIf (CompareFileTime(aWFD.ftLastWriteTime, m3Months) < 0) Then 476 mLessThan6 = mLessThan6 + 1 477 Else 478 mLessThan3 = mLessThan3 + 1 479 End If 480 481End Function 482 483Private Function BasicDateToFileTime(basDate As Date, _ 484 fileDate As FILETIME) As Boolean 485 486 Dim sysDate As SYSTEMTIME 487 Dim retval As Long 488 489 sysDate.wYear = DatePart("yyyy", basDate) 490 sysDate.wMonth = DatePart("m", basDate) 491 sysDate.wDay = DatePart("d", basDate) 492 sysDate.wHour = DatePart("h", basDate) 493 sysDate.wMinute = DatePart("m", basDate) 494 retval = SystemTimeToFileTime(sysDate, fileDate) 495 If (retval = 0) Then 496 BasicDateToFileTime = False 497 Else 498 BasicDateToFileTime = True 499 End If 500End Function 501 502Private Function InitFileTimes() As Boolean 503 504 Dim nowDate As Date 505 Dim basDate As Date 506 507 InitFileTimes = True 508 509 nowDate = Now() 510 basDate = DateAdd("m", -3, nowDate) 511 If Not BasicDateToFileTime(basDate, m3Months) Then InitFileTimes = False 512 513 basDate = DateAdd("m", -6, nowDate) 514 If Not BasicDateToFileTime(basDate, m6Months) Then InitFileTimes = False 515 516 basDate = DateAdd("yyyy", -1, nowDate) 517 If Not BasicDateToFileTime(basDate, m12Months) Then InitFileTimes = False 518 519 mMoreThan12 = 0 520 mLessThan12 = 0 521 mLessThan6 = 0 522 mLessThan3 = 0 523 524End Function 525