'Version 2.31
'Andreas Killer
'11.04.2018
'Replica of the office FileSearch object
Option Explicit
Option Compare Text
'Set this define to False if you use Office 2003 or prior versions
#Const UseNewOfficeFileExtensions = True
'Support unicode chars in filenames, otherwise ANSI chars only
#Const UniCode = True
'This event is raised before the search goes into a subdirectory
' Set Cancel to True to skip that folder (and its subfolders)
Public Event BeforeSearchFolder(ByVal Path As String, ByRef Cancel As Boolean)
#Const FoundEvents = True
#If FoundEvents Then
'This event is raised when a file is found, set Cancel to True to skip that file
Public Event FoundFile(ByVal FullName As String, ByVal Attributes As Long, ByVal DateCreated As Date, _
ByVal DateLastAccessed As Date, ByVal DateLastModified As Date, ByVal Size As Variant, ByRef Cancel As Boolean)
'This event is raised when a folder is found, set Cancel to True to skip that folder
Public Event FoundFolder(ByVal FullName As String, ByVal Attributes As Long, ByVal DateCreated As Date, _
ByVal DateLastAccessed As Date, ByVal DateLastModified As Date, ByRef Cancel As Boolean)
#End If
' Sub Example_FileSearch()
' Dim ApplicationFileSearch As New FileSearch
' Dim FName
' With ApplicationFileSearch
' 'Setup a file mask to search for
' .FileName = "*.*"
' 'Remarks:
' 'A 3 characters long extension did not find a 4 characters long extension
' ' Means *.xlsm or *.xlsx files are not found if you search for *.xls
' ' If you want to include that files, search for "*.xls*"
' ' If you want to exclude *.xls files, search for "*.xls?"
' ' Search for *.* to find all files
' ' Search for *.*.* to find only files with a dot in the filename
' 'You can search with multiple masks at the same time if you use an array
' ' E.g. if you want to find different picture file types:
' ' .FileName = Array("*.jpg", "*.jpeg", "*.bmp", "*.gif")
' ' The .FileType property fills the .FileName property with some predefinied arrays
' ' E.g. this searches for all Excel files .FileType = msoFileTypeExcelWorkbooks
'
' 'Setup a path to search for files
' .LookIn = "C:\"
' 'Remarks:
' ' If the class is initialized or if you call .NewSearch the path is set
' ' to your personal directory, e.g. "C:\Users\UserName\Documents" on Win7
'
' 'Search through sub folders or not, the default value is False
' .SearchSubFolders = True
'
' 'If you want to find a files that you have modified, but you can't remember the filename
' ' use the .LastModified property and specify a time period
' ' The default value of this property is msoLastModifiedAnyTime
' '.LastModified = msoLastModifiedToday
'
' 'Execute the search, the number of found files are returned
' If .Execute > 0 Then
' 'Remarks:
' ' The argument AlwaysAccurate does nothing, it is only for backward compatibility
' ' The returned order of the files is unsorted by default
' ' You can sort by FileName, FileType (Extension), LastModified or Size ascending or descending
'
' 'After a successfully search, two collections are filled with the results:
' ' .FoundFiles contains all found files
' ' .FoundDirs contains all found directories
' '
' 'You can access a collection in 2 ways:
' ' Many people do an index access like this
' ' For i = 1 To .FoundFiles.Count
' ' FName = .FoundFiles(i)
' ' Next
'
' 'But a FOR EACH loop executes much faster:
' For Each FName In .FoundFiles
' 'Debug.Print FName
' Next
' End If
' End With
' End Sub
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
Public Enum msoSortOrder
msoSortOrderAscending = 1
msoSortOrderDescending = 2
End Enum
Public SearchSubFolders As Boolean
Public FoundFiles As Collection
Public FoundDirs As Collection
Private fsFileName As Variant
Private fsFileExt As Variant
Private fsFileBase As Variant
Private fsLookIn As String
Private fsFileType As msoFileType
Private fsLastModified As msoLastModified
Private SortFiles As Collection
Private SortDirs As Collection
Private SortFilesBy As msoSortBy
Private fso 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
'MSDN: "This value is not supported until Windows Server 2008 R2 and Windows 7."
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
FindExInfoBasic 'MSDN: "This value is not supported until Windows Server 2008 R2 and Windows 7."
FindExInfoMaxInfoLevel
End Enum
#If Win64 Then
#If UniCode Then
Private Declare PtrSafe Function FindFirstFileEx Lib "kernel32" Alias "FindFirstFileExW" ( _
ByVal lpFileName As LongPtr, ByVal fInfoLevelId As Long, ByVal lpFindFileData As LongPtr, _
ByVal fSearchOp As Long, ByVal lpSearchFilter As Long, ByVal dwAdditionalFlags As Long) As LongPtr
Private Declare PtrSafe Function FindNextFile Lib "kernel32" Alias "FindNextFileW" ( _
ByVal hFindFile As LongPtr, ByVal lpFindFileData As LongPtr) As Long
#Else
Private Declare PtrSafe 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 LongPtr
Private Declare PtrSafe Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
ByVal hFindFile As LongPtr, lpFindFileData As WIN32_FIND_DATA) As Long
#End If
Private Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As LongPtr) As Long
#Else
#If UniCode Then
Private Declare Function FindFirstFileEx Lib "kernel32" Alias "FindFirstFileExW" ( _
ByVal lpFileName As Long, ByVal fInfoLevelId As Long, ByVal lpFindFileData As Long, _
ByVal fSearchOp As Long, ByVal lpSearchFilter As Long, ByVal dwAdditionalFlags As Long) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileW" ( _
ByVal hFindFile As Long, ByVal lpFindFileData As Long) As Long
#Else
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
#End If
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
#End If
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
#If Win64 Then
Private Declare PtrSafe Function FileTimeToSystemTime Lib "kernel32" ( _
lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpDest As Any, lpSource As Any, ByVal nCount As Long)
#Else
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)
#End If
'Private Type SHITEMID
' cb As Long
' abID As Byte
'End Type
'Private Type ITEMIDLIST
' mkID As SHITEMID
'End Type
'
'#If Win64 Then
'Private Declare PtrSafe Function SHGetSpecialFolderLocation Lib "Shell32" ( _
' ByVal hwndOwner As Long, ByVal nFolder As Long, ByRef ppidl As ITEMIDLIST) As Long
'Private Declare PtrSafe Function SHGetPathFromIDList Lib "Shell32" ( _
' ByVal pidList As Long, ByVal lpBuffer As String) As Long
'#Else
'Private Declare Function SHGetSpecialFolderLocation Lib "Shell32" ( _
' ByVal hwndOwner As Long, ByVal nFolder As Long, ByRef ppidl As ITEMIDLIST) As Long
'Private Declare Function SHGetPathFromIDList Lib "Shell32" ( _
' ByVal pidList As Long, ByVal lpBuffer As String) As Long
'#End If
Private IsWow64 As Boolean
#If Win64 Then
Private Declare PtrSafe Function Wow64DisableWow64FsRedirection Lib "kernel32" ( _
ByRef OldValue As Long) As Long
Private Declare PtrSafe Function Wow64RevertWow64FsRedirection Lib "kernel32" ( _
ByVal OldValue As Long) As Long
Private Declare PtrSafe Function GetModuleHandleA Lib "kernel32" ( _
ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" ( _
ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe Function IsWow64Process Lib "kernel32" ( _
ByVal hProcess As LongPtr, ByRef Wow64Process As LongPtr) As Long
Private Declare PtrSafe Function GetCurrentProcess Lib "kernel32" () As LongPtr
#Else
Private Declare Function Wow64DisableWow64FsRedirection Lib "kernel32" ( _
ByRef OldValue As Long) As Long
Private Declare Function Wow64RevertWow64FsRedirection Lib "kernel32" ( _
ByVal OldValue As Long) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" ( _
ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" ( _
ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function IsWow64Process Lib "kernel32" ( _
ByVal hProcess As Long, ByRef Wow64Process As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
#End If
Private Function DetectWow64() As Boolean
#If Win64 Then
Dim Ret As LongPtr
#Else
Dim Ret As Long
#End If
If GetProcAddress(GetModuleHandleA("kernel32.dll"), "IsWow64Process") Then
IsWow64Process GetCurrentProcess, Ret
DetectWow64 = (Ret <> 0)
End If
End Function
Private Function Path2MyDocuments() As String
' Const S_OK = 0
' Const MAX_PATH = 260
' Dim IIDL As ITEMIDLIST
' If SHGetSpecialFolderLocation(0, 5, IIDL) = S_OK Then
' Path2MyDocuments = Space$(MAX_PATH)
' If SHGetPathFromIDList(IIDL.mkID.cb, Path2MyDocuments) Then
' Path2MyDocuments = Left$(Path2MyDocuments, InStr(Path2MyDocuments, vbNullChar) - 1)
' Else
' Path2MyDocuments = ""
' End If
' End If
Dim WSHShell As Object
Set WSHShell = CreateObject("Wscript.Shell")
Path2MyDocuments = WSHShell.SpecialFolders("MyDocuments")
End Function
Private Sub Class_Initialize()
Set FoundDirs = New Collection
Set FoundFiles = New Collection
Set SortFiles = New Collection
Set SortDirs = New Collection
Set fso = CreateObject("Scripting.FileSystemObject")
FileType = msoFileTypeOfficeFiles
LastModified = msoLastModifiedAnyTime
LookIn = Path2MyDocuments
IsWow64 = DetectWow64
End Sub
Private Sub Class_Terminate()
Set FoundDirs = Nothing
Set FoundFiles = Nothing
Set SortFiles = Nothing
Set SortDirs = Nothing
Set fso = Nothing
End Sub
Public Sub NewSearch()
FileName = ""
LookIn = Path2MyDocuments
FileType = msoFileTypeOfficeFiles
LastModified = msoLastModifiedAnyTime
SearchSubFolders = False
ClearCollections
End Sub
Private Sub ClearCollections()
If FoundFiles.Count > 0 Then
Set FoundFiles = Nothing
Set FoundFiles = New Collection
Set SortFiles = Nothing
Set SortFiles = New Collection
End If
If FoundDirs.Count > 0 Then
Set FoundDirs = Nothing
Set FoundDirs = New Collection
Set SortDirs = Nothing
Set SortDirs = New Collection
End If
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
#If UseNewOfficeFileExtensions Then
Select Case Value
Case msoFileTypeAllFiles
fsFileName = Array("*.*")
Case msoFileTypeOfficeFiles
fsFileName = Array( _
"*.doc", "*.docm", "*.docx", "*.dot", "*.dotm", "*.dotx", _
"*.htm", "*.html", _
"*.mdb", "*.mdbm", "*.mdbx", "*.mpd", "*.mpdm", "*.mpdx", _
"*.obd", "*.obdm", "*.obdx", "*.obt", "*.obtm", "*.obtx", _
"*.pot", "*.potm", "*.potx", "*.pps", "*.ppsm", "*.ppsx", "*.ppt", "*.pptm", "*.pptx", _
"*.xls", "*.xlsm", "*.xlsx", "*.xlt", "*.xltm", "*.xltx", "*.xlsb")
Case msoFileTypeWordDocuments
fsFileName = Array("*.doc", "*.docm", "*.docx", "*.htm", "*.html")
Case msoFileTypeExcelWorkbooks
fsFileName = Array("*.xls", "*.xlsm", "*.xlsx", "*.xlsb")
Case msoFileTypePowerPointPresentations
fsFileName = Array("*.pps", "*.ppsm", "*.ppsx", "*.ppt", "*.pptm", "*.pptx")
Case msoFileTypeBinders
fsFileName = Array("*.obd", "*.obdm", "*.obdx")
Case msoFileTypeDatabases
fsFileName = Array("*.mdb", "*.mdbm", "*.mdbx", "*.mpd", "*.mpdm", "*.mpdx")
Case msoFileTypeTemplates
fsFileName = Array( _
"*.dot", "*.dotm", "*.dotx", _
"*.obt", "*.obtm", "*.obtx", _
"*.pot", "*.potm", "*.potx", _
"*.xlt", "*.xltm", "*.xltx")
Case Else
fsFileType = 0
fsFileName = Array("*.*")
End Select
#Else
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 If
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
Property Let LookIn(ByVal Value As String)
fsLookIn = fso.BuildPath(fso.GetAbsolutePathName(Value), "\")
End Property
Property Get LookIn() As String
LookIn = fsLookIn
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)
#If Win64 Then
Dim hFindFile As LongPtr
#Else
Dim hFindFile As Long
#End If
Dim hFoundFile As WIN32_FIND_DATA
Dim FName As String
Dim STime As SYSTEMTIME
Dim FTime As Date, ETime As Date, LTime As Date
Dim CTime As Date, MTime As Date, ATime As Date
Dim i As Integer, j As Long
Dim AddIt As Boolean, Cancel 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
'Suche nach den Dateien
For i = LBound(fsFileName) To UBound(fsFileName)
#If UniCode Then
hFindFile = FindFirstFileEx(StrPtr(Path & fsFileName(i) & vbNullChar), _
FindExInfoStandard&, VarPtr(hFoundFile), FindExSearchNameMatch&, 0&, 0&)
#Else
hFindFile = FindFirstFileEx(Path & fsFileName(i) & vbNullChar, _
FindExInfoStandard&, hFoundFile, FindExSearchNameMatch&, 0&, 0&)
#End If
If hFindFile <> INVALID_HANDLE_VALUE Then
Do
With hFoundFile
'Die Verzeichnisse ausschließen
If (.dwFileAttributes And vbDirectory) = 0 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
j = InStr(.cFileName, vbNullChar) - 1
FName = Mid$(.cFileName, 1, j)
If j - InStrRev(FName, ".") > 3 Or Len(fsFileExt(i)) > 3 Then
'Problem *.htm findet auch *.html
AddIt = fso.GetExtensionName(FName) Like fsFileExt(i) And fso.GetBaseName(FName) Like fsFileBase(i)
End If
End If
#If FoundEvents Then
If AddIt Then
FileTimeToSystemTime .ftLastAccessTime, STime
With STime
ATime = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
End With
FileTimeToSystemTime .ftLastWriteTime, STime
With STime
MTime = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
End With
FileTimeToSystemTime .ftCreationTime, STime
With STime
CTime = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
End With
RaiseEvent FoundFile(Path & FName, .dwFileAttributes, CTime, ATime, MTime, MakeDecimal(.nFileSizeLow, .nFileSizeHigh), AddIt)
End If
#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 fso.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
Else
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
'Problem Verzeichnisse "." und ".." ausschließen, aber alle anderen zulassen (.borland)
AddIt = InStr(.cAlternate, vbNullChar) > 1
If Not AddIt Then
For j = 1 To Len(.cFileName)
Select Case Mid$(.cFileName, j, 1)
Case "."
Case vbNullChar
Exit For
Case Else
AddIt = True
Exit For
End Select
Next
End If
End If
If AddIt Then
FName = Mid$(.cFileName, 1, InStr(.cFileName, vbNullChar) - 1)
If InStr(FName, "?") > 0 Then
'Problem Verzeichnisse mit ungültigen Zeichen "??sortierte Lesezeichen"
FName = Mid$(.cAlternate, 1, InStr(.cAlternate, vbNullChar) - 1)
End If
End If
#If FoundEvents Then
If AddIt Then
FileTimeToSystemTime .ftLastAccessTime, STime
With STime
ATime = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
End With
FileTimeToSystemTime .ftLastWriteTime, STime
With STime
MTime = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
End With
FileTimeToSystemTime .ftCreationTime, STime
With STime
CTime = DateSerial(.wYear, .wMonth, .wDay) + TimeSerial(.wHour, .wMinute, .wSecond)
End With
RaiseEvent FoundFolder(Path & FName, .dwFileAttributes, CTime, ATime, MTime, AddIt)
End If
#End If
If AddIt Then
FoundDirs.Add Path & FName
'Sollen wir sortieren?
Select Case SortFilesBy
Case msoSortByFileName
'Pfad
SortDirs.Add Path & FName
Case msoSortByFileType
'Extension, dann Pfad, dann Name
SortDirs.Add fso.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
SortDirs.Add FTime
Case msoSortBySize
SortDirs.Add MakeDecimal(.nFileSizeLow, .nFileSizeHigh)
End Select
End If
End If
End With
#If UniCode Then
Loop Until FindNextFile(hFindFile, VarPtr(hFoundFile)) <> 1
#Else
Loop Until FindNextFile(hFindFile, hFoundFile) <> 1
#End If
FindClose hFindFile
End If
Next
If SearchSubFolders Then
'Suche nach einem Verzeichnis
'Problem "*." findet keine Verzeichnisse die einen Punkt enthalten!
#If UniCode Then
hFindFile = FindFirstFileEx(StrPtr(Path & "*" & vbNullChar), _
FindExInfoStandard&, VarPtr(hFoundFile), FindExSearchLimitToDirectories&, 0&, 0&)
#Else
hFindFile = FindFirstFileEx(Path & "*" & vbNullChar, _
FindExInfoStandard&, hFoundFile, FindExSearchLimitToDirectories&, 0&, 0&)
#End If
If hFindFile <> INVALID_HANDLE_VALUE Then
Do
With hFoundFile
If (.dwFileAttributes And vbDirectory) > 0 Then
'Problem Verzeichnisse "." und ".." ausschließen, aber alle anderen zulassen (.borland)
AddIt = InStr(.cAlternate, vbNullChar) > 1
If Not AddIt Then
'AddIt = Left$(.cFileName, 1) <> "."
For j = 1 To Len(.cFileName)
Select Case Mid$(.cFileName, j, 1)
Case "."
Case vbNullChar
Exit For
Case Else
AddIt = True
Exit For
End Select
Next
End If
If AddIt Then
FName = Mid$(.cFileName, 1, InStr(.cFileName, vbNullChar) - 1)
If InStr(FName, "?") > 0 Then
'Problem Verzeichnisse mit ungültigen Zeichen "??sortierte Lesezeichen"
FName = Mid$(.cAlternate, 1, InStr(.cAlternate, vbNullChar) - 1)
End If
Cancel = False
RaiseEvent BeforeSearchFolder(Path & FName, Cancel)
'Starte rekursive Suche
If Not Cancel Then SearchPrim Path & FName & "\"
End If
End If
End With
#If UniCode Then
Loop Until FindNextFile(hFindFile, VarPtr(hFoundFile)) <> 1
#Else
Loop Until FindNextFile(hFindFile, hFoundFile) <> 1
#End If
FindClose hFindFile
End If
End If
End Sub
Private Sub QuickSortCollection(ByRef Liste As Collection, ByRef Data As Collection, _
Optional ByVal Compare As VbCompareMethod = vbDatabaseCompare, _
Optional ByVal SortOrder As msoSortOrder = msoSortOrderAscending)
'Sortiert eine Collection mit beliebigen Werten, führt eine zweite Collection parallel mit
Const QTHRESH As Long = 9
Dim i As Long, j As Long, C As Integer, Ci As Integer, Cj As Integer
Dim Pivot, Temp
Dim DArr(), LArr()
Dim DoResume As Boolean
Dim Stack(1 To 64) As Long
Dim StackPtr As Long
Dim Start As Long, Ende As Long
'Wir brauchen mind. 2 Elemente
If Liste.Count < 2 Then Exit Sub
'Daten aus der Collection in ein Array übertragen
ReDim LArr(1 To Liste.Count)
ReDim DArr(1 To Liste.Count)
i = 0
For Each Temp In Liste
i = i + 1
LArr(i) = Temp
Next
i = 0
For Each Temp In Data
i = i + 1
DArr(i) = Temp
Next
Start = 1
Ende = UBound(LArr)
If SortOrder = msoSortOrderAscending Then C = 1 Else C = -1
Ci = 1
Stack(StackPtr + 1) = Start
Stack(StackPtr + 2) = Ende
StackPtr = StackPtr + 2
Do
StackPtr = StackPtr - 2
Start = Stack(StackPtr + 1)
Ende = Stack(StackPtr + 2)
If Ende - Start < QTHRESH Then
'Insertionsort
Select Case Compare
Case vbDatabaseCompare
'Zahlen sortieren
If SortOrder = msoSortOrderAscending Then
For j = Start + 1 To Ende
Pivot = LArr(j)
Temp = DArr(j)
For i = j - 1 To Start Step -1
If LArr(i) <= Pivot Then Exit For
LArr(i + 1) = LArr(i)
DArr(i + 1) = DArr(i)
Next
LArr(i + 1) = Pivot
DArr(i + 1) = Temp
Next
Else
For j = Start + 1 To Ende
Pivot = LArr(j)
Temp = DArr(j)
For i = j - 1 To Start Step -1
If LArr(i) >= Pivot Then Exit For
LArr(i + 1) = LArr(i)
DArr(i + 1) = DArr(i)
Next
LArr(i + 1) = Pivot
DArr(i + 1) = Temp
Next
End If
Case vbTextCompare
'Texte sortieren => MatchCase:=False
For j = Start + 1 To Ende
Pivot = LArr(j)
Temp = DArr(j)
For i = j - 1 To Start Step -1
Ci = StrComp(LArr(i), Pivot, Compare)
If Ci <> C Then Exit For
LArr(i + 1) = LArr(i)
DArr(i + 1) = DArr(i)
Next
LArr(i + 1) = Pivot
DArr(i + 1) = Temp
Next
End Select
Else
'QuickSort
i = Start: j = Ende
Pivot = LArr((Start + Ende) \ 2)
Do
Select Case Compare
Case vbDatabaseCompare
'Zahlen sortieren
If SortOrder = msoSortOrderAscending Then
Do While (LArr(i) < Pivot): i = i + 1: Loop
Do While (LArr(j) > Pivot): j = j - 1: Loop
Else
Do While (LArr(i) > Pivot): i = i + 1: Loop
Do While (LArr(j) < Pivot): j = j - 1: Loop
End If
Case vbTextCompare
'Texte sortieren => MatchCase:=False
Ci = StrComp(LArr(i), Pivot, Compare)
Do While (Ci = -C)
i = i + 1
Ci = StrComp(LArr(i), Pivot, Compare)
Loop
Cj = StrComp(LArr(j), Pivot, Compare)
Do While (Cj = C)
j = j - 1
Cj = StrComp(LArr(j), Pivot, Compare)
Loop
End Select
If i <= j Then
If i < j And Not (Ci = 0 And Cj = 0) Then
Temp = DArr(i)
DArr(i) = DArr(j)
DArr(j) = Temp
Temp = LArr(i)
LArr(i) = LArr(j)
LArr(j) = Temp
End If
i = i + 1: j = j - 1
End If
Loop Until i > j
If (Start < j) Then
'QuickSort LArr, Start, j, Compare, SortOrder
Stack(StackPtr + 1) = Start
Stack(StackPtr + 2) = j
StackPtr = StackPtr + 2
End If
If (i < Ende) Then
'QuickSort LArr, i, Ende, Compare, SortOrder
Stack(StackPtr + 1) = i
Stack(StackPtr + 2) = Ende
StackPtr = StackPtr + 2
End If
End If
Loop Until StackPtr = 0
'Collection neu aufbauen
Set Data = Nothing
Set Data = New Collection
For i = 1 To UBound(DArr)
Data.Add DArr(i)
Next
End Sub
Public Function Execute( _
Optional SortBy As msoSortBy = 0, _
Optional SortOrder As msoSortOrder = msoSortOrderAscending, _
Optional AlwaysAccurate As Boolean = True) 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
Dim i As Integer
Dim OldValue64Bit As Long
ReDim fsFileExt(LBound(fsFileName) To UBound(fsFileName))
ReDim fsFileBase(LBound(fsFileName) To UBound(fsFileName))
For i = LBound(fsFileName) To UBound(fsFileName)
fsFileExt(i) = fso.GetExtensionName(fsFileName(i))
fsFileBase(i) = fso.GetBaseName(fsFileName(i))
Next
ClearCollections
SortFilesBy = SortBy
If IsWow64 Then
If Wow64DisableWow64FsRedirection(OldValue64Bit) = 0 Then IsWow64 = False
End If
SearchPrim fsLookIn
If IsWow64 Then Wow64RevertWow64FsRedirection OldValue64Bit
Execute = FoundFiles.Count
Select Case SortBy
Case msoSortByFileName, msoSortByFileType
QuickSortCollection SortFiles, FoundFiles, vbTextCompare, SortOrder
QuickSortCollection SortDirs, FoundDirs, vbTextCompare, SortOrder
Case msoSortByLastModified, msoSortBySize
QuickSortCollection SortFiles, FoundFiles, vbDatabaseCompare, SortOrder
QuickSortCollection SortDirs, FoundDirs, vbDatabaseCompare, SortOrder
End Select
End Function
Reply With Quote