'Version 1.2
'Andreas Killer
'12.10.09
'Attribute VB_Name = "FileSearch"
'Nachbildung des FileSearch-Objektes für Office 2007
'Property-Tests sind nicht implementiert!
Option Explicit
Public Enum msoSortBy
msoSortByFileName = 1
msoSortBySize = 2
msoSortByFileType = 3
msoSortByLastModified = 4
End Enum
Public Enum msoFileType
msoFileTypeAllFiles = 1
msoFileTypeOfficeFiles = 2
msoFileTypeWordDocuments = 3
msoFileTypeExcelWorkbooks = 4
msoFileTypePowerPointPresentations = 5
msoFileTypeBinders = 6
msoFileTypeDatabases = 7
msoFileTypeTemplates = 8
End Enum
Public Enum msoLastModified
msoLastModifiedYesterday = 1
msoLastModifiedToday = 2
msoLastModifiedLastWeek = 3
msoLastModifiedThisWeek = 4
msoLastModifiedLastMonth = 5
msoLastModifiedThisMonth = 6
msoLastModifiedAnyTime = 7
End Enum
Private fsFileName As Variant
Public LookIn As String
Public SearchSubFolders As Boolean
Public FoundFiles As Collection
Private fsFileType As msoFileType
Private fsLastModified As msoLastModified
Private SortFiles As Collection
Private SortFilesBy As msoSortBy
Private fs As Object 'FileSystemObject
Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH = 260
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 Const FIND_FIRST_EX_CASE_SENSITIVE As Long = 1
Private Const FIND_FIRST_EX_LARGE_FETCH As Long = 2
Private Enum FINDEX_SEARCH_OPS
FindExSearchNameMatch
FindExSearchLimitToDirectories
FindExSearchLimitToDevices
End Enum
Private Enum FINDEX_INFO_LEVELS
FindExInfoStandard
FindExInfoMaxInfoLevel
End Enum
Private Declare Function FindFirstFile Lib "kernel32" Alias _
"FindFirstFileA" (ByVal lpFileName As String, lpFindFileData _
As WIN32_FIND_DATA) As Long
Private Declare Function FindFirstFileEx Lib "kernel32" Alias _
"FindFirstFileExA" (ByVal lpFileName As String, ByVal _
fInfoLevelId As Long, lpFindFileData As WIN32_FIND_DATA, _
ByVal fSearchOp As Long, ByVal lpSearchFilter As Long, ByVal _
dwAdditionalFlags As Long) 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 lstrlenA Lib "kernel32" (ByVal _
psString As Any) As Long
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Declare Function FileTimeToSystemTime Lib "kernel32" ( _
lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal nCount _
As Long)
Private Sub Class_Initialize()
Set FoundFiles = New Collection
Set SortFiles = New Collection
Set fs = CreateObject("Scripting.FileSystemObject")
FileType = msoFileTypeOfficeFiles
LastModified = msoLastModifiedAnyTime
End Sub
Private Sub Class_Terminate()
Set FoundFiles = Nothing
Set SortFiles = Nothing
Set fs = Nothing
End Sub
Public Sub NewSearch()
Filename = ""
LookIn = ""
FileType = msoFileTypeOfficeFiles
LastModified = msoLastModifiedAnyTime
SearchSubFolders = False
ClearCollections
End Sub
Private Sub ClearCollections()
Dim I As Long
With SortFiles
For I = .Count To 1 Step -1
.Remove I
Next
End With
With FoundFiles
For I = .Count To 1 Step -1
.Remove I
Next
End With
End Sub
Property Let Filename(Value As Variant)
If IsArray(Value) Then
fsFileName = Value
Else
fsFileName = Array(Value)
End If
fsFileType = 0
End Property
Property Get Filename() As Variant
Filename = Join(fsFileName, ", ")
End Property
Property Let FileType(Value As msoFileType)
fsFileType = Value
Select Case Value
Case msoFileTypeAllFiles
fsFileName = Array("*.*")
Case msoFileTypeOfficeFiles
fsFileName = Array("*.doc", "*.dot", "*.htm", "*.html", _
"*.mdb", "*.mpd", "*.obd", "*.obt", "*.pot", "*.pps", "*.ppt", _
"*.xls", "*.xlt")
Case msoFileTypeWordDocuments
fsFileName = Array("*.doc", "*.htm", "*.html")
Case msoFileTypeExcelWorkbooks
fsFileName = Array("*.xls")
Case msoFileTypePowerPointPresentations
fsFileName = Array("*.pps", "*.ppt")
Case msoFileTypeBinders
fsFileName = Array("*.obd")
Case msoFileTypeDatabases
fsFileName = Array("*.mdb", "*.mpd")
Case msoFileTypeTemplates
fsFileName = Array("*.dot", "*.obt", "*.pot", "*.xlt")
Case Else
fsFileType = 0
fsFileName = Array("*.*")
End Select
End Property
Property Get FileType() As msoFileType
FileType = fsFileType
End Property
Property Let LastModified(Value As msoLastModified)
If Value >= 1 And Value <= 7 Then
fsLastModified = Value
Else
fsLastModified = msoLastModifiedAnyTime
End If
End Property
Property Get LastModified() As msoLastModified
LastModified = fsLastModified
End Property
Private Function MakeDecimal(ByVal Lo As Long, ByVal Hi As _
Long, Optional ByVal wEx As Long = 0, Optional Minus As _
Boolean = False) As Variant
If Minus Then MakeDecimal = CDec(-1) Else MakeDecimal = CDec(1)
CopyMemory ByVal VarPtr(MakeDecimal) + 8, Lo, 4
CopyMemory ByVal VarPtr(MakeDecimal) + 12, Hi, 4
If wEx <> 0 Then CopyMemory ByVal VarPtr(MakeDecimal) + 4, _
Lo, 4
End Function
Private Function FirstWeek(ByVal Datum As Date) As Date
'Liefert den 1. Tag der Woche in dem Datum liegt
FirstWeek = Datum - Weekday(Datum, vbUseSystemDayOfWeek) + 1
End Function
Private Sub SearchPrim(ByVal Path As String)
Dim hFindFile As Long, hFoundFile As WIN32_FIND_DATA
Dim FName As String, STime As SYSTEMTIME, FTime As Date, _
ETime As Date, LTime As Date
Dim I As Integer, AddIt As Boolean
If fsLastModified <> msoLastModifiedAnyTime Then
Select Case fsLastModified
Case msoLastModifiedYesterday
ETime = Date - 1
LTime = Date - 1
Case msoLastModifiedToday
ETime = Date
LTime = Date
Case msoLastModifiedLastWeek
ETime = FirstWeek(Date) - 7
LTime = ETime + 6
Case msoLastModifiedThisWeek
ETime = FirstWeek(Date)
LTime = ETime + 6
Case msoLastModifiedLastMonth
ETime = DateSerial(Year(Date), Month(Date) - 1, 1)
LTime = DateSerial(Year(Date), Month(Date), 0)
Case msoLastModifiedThisMonth
ETime = DateSerial(Year(Date), Month(Date), 1)
LTime = DateSerial(Year(Date), Month(Date) + 1, 0)
End Select
End If
'Sicherstelen das ein Backslash dran ist
If Right(Path, 1) <> "\" Then Path = Path & "\"
'Suche nach den Dateien
For I = LBound(fsFileName) To UBound(fsFileName)
'hFindFile = FindFirstFile(Path & fsFileName(I) & Chr(0), _
hFoundFile)
hFindFile = FindFirstFileEx(Path & fsFileName(I) & Chr(0), _
FindExInfoStandard&, hFoundFile, FindExSearchNameMatch&, 0&, 0&)
If hFindFile <> INVALID_HANDLE_VALUE Then
Do
With hFoundFile
'Die Verzeichnisse ausschließen
If Not (.dwFileAttributes And vbDirectory) = _
vbDirectory Then
If fsLastModified = msoLastModifiedAnyTime Then
AddIt = True
Else
'Konvertiere Dateizeit zu Systemzeit
FileTimeToSystemTime .ftLastWriteTime, STime
'Generiere VBA-Datum
With STime
FTime = DateSerial(.wYear, .wMonth, .wDay)
End With
AddIt = FTime >= ETime And FTime <= LTime
End If
If AddIt Then
FName = Mid$(.cFileName, 1, lstrlenA(.cFileName))
'Problem *.htm findet auch *.html
AddIt = FName Like fsFileName(I)
End If
If AddIt Then
FoundFiles.Add Path & FName
'Sollen wir sortieren?
Select Case SortFilesBy
Case msoSortByFileName
'Pfad, dann Name
SortFiles.Add FName & Path
Case msoSortByFileType
'Extension, dann Pfad, dann Name
SortFiles.Add fs.GetExtensionName(FName) & _
Path & FName
Case msoSortByLastModified
'Konvertiere Dateizeit zu Systemzeit
FileTimeToSystemTime .ftLastWriteTime, STime
'Generiere VBA-Datum
With STime
FTime = DateSerial(.wYear, .wMonth, .wDay) _
+ TimeSerial(.wHour, .wMinute, .wSecond)
End With
SortFiles.Add FTime
Case msoSortBySize
SortFiles.Add MakeDecimal(.nFileSizeLow, _
.nFileSizeHigh)
End Select
End If
End If
End With
Loop Until FindNextFile(hFindFile, hFoundFile) <> 1
FindClose hFindFile
End If
Next
If SearchSubFolders Then
'Suche nach einem Verzeichnis
'hFindFile = FindFirstFile(Path & "*." & Chr(0), hFoundFile)
'hFindFile = FindFirstFileEx(Path & "*." & Chr(0), _
FindExInfoStandard&, hFoundFile, _
FindExSearchLimitToDirectories&, 0&, FIND_FIRST_EX_LARGE_FETCH)
hFindFile = FindFirstFileEx(Path & "*." & Chr(0), _
FindExInfoStandard&, hFoundFile, _
FindExSearchLimitToDirectories&, 0&, 0&)
If hFindFile <> INVALID_HANDLE_VALUE Then
Do
With hFoundFile
'Die Verzeichnisse "." und ".." ausschließen
If Left$(.cFileName, 1) <> "." And ( _
.dwFileAttributes And vbDirectory) = vbDirectory Then
FName = Mid$(.cFileName, 1, lstrlenA(.cFileName))
'Starte rekursive Suche
SearchPrim Path & FName
End If
End With
Loop Until FindNextFile(hFindFile, hFoundFile) <> 1
FindClose hFindFile
End If
End If
End Sub
Private Sub QuickSortCollection(ByRef Liste As Collection, _
ByRef Data As Collection, Optional Start, Optional Ende, _
Optional Compare As vbCompareMethod = vbDatabaseCompare, _
Optional SortOrder As MsoSortOrder = msoSortOrderAscending)
'Sortiert eine Collection mit beliebigen Werten im Bereich _
Start..Ende, führt die Data-Collection parallel mit
'vbDatabaseCompare sortiert Zahlen, ansonsten werden Texte _
sortiert
Dim I As Long, J As Long, C As Integer, Pivot As Variant
If Liste.Count <= 1 Then Exit Sub
If IsMissing(Start) Then Start = 1
If IsMissing(Ende) Then Ende = Liste.Count
If SortOrder = msoSortOrderAscending Then C = 1 Else C = -1
I = Start: J = Ende
Pivot = Liste((Start + Ende) \ 2)
Do
If Compare = vbDatabaseCompare Then
'Zahlen sortieren
If SortOrder = msoSortOrderAscending Then
While (Liste(I) < Pivot): I = I + 1: Wend
While (Liste(J) > Pivot): J = J - 1: Wend
Else
While (Liste(I) > Pivot): I = I + 1: Wend
While (Liste(J) < Pivot): J = J - 1: Wend
End If
Else
'Texte sortieren
Do While (StrComp(Liste(I), Pivot, Compare) = -C): I = I _
+ 1: Loop
Do While (StrComp(Liste(J), Pivot, Compare) = C): J = J - _
1: Loop
End If
If (I <= J) Then
If I < J Then
Liste.Add Liste(I), After:=J
Liste.Add Liste(J), After:=I
Liste.Remove I
Liste.Remove J
Data.Add Data(I), After:=J
Data.Add Data(J), After:=I
Data.Remove I
Data.Remove J
End If
I = I + 1: J = J - 1
End If
Loop Until (I > J)
If (Start < J) Then QuickSortCollection Liste, Data, Start, _
J, Compare, SortOrder
If (I < Ende) Then QuickSortCollection Liste, Data, I, Ende, _
Compare, SortOrder
End Sub
Public Function Execute(Optional SortBy As msoSortBy = 0, _
Optional SortOrder As MsoSortOrder = msoSortOrderAscending, _
Optional AlwaysAccurate As Boolean = True) As Long
Dim I As Long
'Beginnt die Suche nach den angegebenen Dateien.
'SortBy:
' Die für die Sortierung der zurückgegebenen Dateien _
verwendete Methode. Dies kann eine der folgenden MsoSortBy- _
Konstanten sein: msoSortbyFileName, msoSortbyFileType, _
msoSortbyLastModified oder msoSortbySize. Ist SortBy = 0 wird _
nicht sortiert
'SortOrder:
' Die Reihenfolge, in der die zurückgegebenen Dateien _
sortiert werden sollen. Dies kann eine der folgenden _
MsoSortOrder-Konstanten sein: msoSortOrderAscending oder _
msoSortOrderDescending.
'AlwaysAccurate:
' Ohne Funktion, nur aus Kompatiblitätsgründen
ClearCollections
SortFilesBy = SortBy
SearchPrim LookIn
Execute = FoundFiles.Count
Select Case SortBy
Case msoSortByFileName, msoSortByFileType
QuickSortCollection SortFiles, FoundFiles, Compare:= _
vbTextCompare, SortOrder:=SortOrder
Case msoSortByLastModified, msoSortBySize
QuickSortCollection SortFiles, FoundFiles, Compare:= _
vbDatabaseCompare, SortOrder:=SortOrder
End Select
End Function
