AW: Application.FileSearch in Excel 2007
03.03.2008 10:39:00
Nepumuk
Hallo Dieter,
eine mögliche Alternative:
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Public Enum SORT_BY
Sort_by_None
Sort_by_Name
Sort_by_Path
Sort_by_Size
Sort_by_Last_Access
Sort_by_Last_Modyfy
Sort_by_Date_Create
End Enum
Public Enum SORT_ORDER
Sort_Order_Ascending
Sort_Order_Descending
End Enum
Public Type FILEINFO
strFilename As String
strPath As String
lngSize As Long
dmtLastAccess As Date
dmtLastModify As Date
dmtDateCreate As Date
End Type
Public Sub Test()
Dim objFileSearch As clsFileSearch
Dim lngIndex As Long
Set objFileSearch = New clsFileSearch
With objFileSearch
.CaseSenstiv = False
.Extension = "*.xls"
.FolderPath = "D:\"
.SearchLike = "*test*"
.SubFolders = True
If .Execute(Sort_by_Size, Sort_Order_Descending) > 0 Then
For lngIndex = 1 To .FileCount
With .Files(lngIndex)
'do something
End With
Next
Else
MsgBox "Nix gefunden"
End If
End With
Set objFileSearch = Nothing
End Sub
' **********************************************************************
' Modul: clsFileSearch Typ: Klassenmodul
' **********************************************************************
Option Explicit
Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, _
ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32.dll" ( _
ByVal hFindFile As Long) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32.dll" ( _
ByRef lpFileTime As FILETIME, _
ByRef lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32.dll" ( _
ByRef lpFileTime As FILETIME, _
ByRef lpSystemTime As SYSTEMTIME) As Long
Private Enum FILE_ATTRIBUTE
FILE_ATTRIBUTE_READONLY = &H1
FILE_ATTRIBUTE_HIDDEN = &H2
FILE_ATTRIBUTE_SYSTEM = &H4
FILE_ATTRIBUTE_DIRECTORY = &H10
FILE_ATTRIBUTE_ARCHIVE = &H20
FILE_ATTRIBUTE_NORMAL = &H80
FILE_ATTRIBUTE_TEMPORARY = &H100
End Enum
Private Const MAX_PATH = 260&
Private Const INVALID_HANDLE_VALUE = -1&
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
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 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 mlngFileCount As Long
Private mudtFiles() As FILEINFO
Private mstrFolderPath As String
Private mstrExtension As String
Private mstrSearchLike As String
Private mstrNotSearchLike As String
Private mblnSubFolders As Boolean
Private mblnCaseSenstiv As Boolean
Friend Property Get Files(lngIndex As Long) As FILEINFO
'//return property single file
Files = mudtFiles(lngIndex)
End Property
Friend Property Get FileCount() As Long
'//return property count of found files
FileCount = mlngFileCount
End Property
Friend Property Let FolderPath(strFolderPath As String)
'//set property path
mstrFolderPath = strFolderPath
End Property
Friend Property Let Extension(strExtension As String)
'//set property extension
mstrExtension = strExtension
If Left$(mstrExtension, 2) <> "*." Then mstrExtension = "*." & mstrExtension
End Property
Friend Property Let SearchLike(strSearchLike As String)
'//set property like-string in filename
mstrSearchLike = strSearchLike
End Property
Friend Property Let NotSearchLike(strNotSearchLike As String)
'//set property not-like-string in filename
mstrNotSearchLike = strNotSearchLike
End Property
Friend Property Let SubFolders(blnSubFolders As Boolean)
'//set property search in subfolders
mblnSubFolders = blnSubFolders
End Property
Friend Property Let CaseSenstiv(blnCaseSenstiv As Boolean)
'//set property filename search case sensitive
mblnCaseSenstiv = blnCaseSenstiv
End Property
Friend Function Execute(Optional enmSortBy As SORT_BY = Sort_by_None, _
Optional enmSortOrder As SORT_ORDER = Sort_Order_Ascending) As Long
'//search files
Call FindFiles(mstrFolderPath)
'//optional sotrparameters are give
If mlngFileCount > 1 And enmSortBy <> Sort_by_None Then _
Call QuickSort(1, mlngFileCount, enmSortBy, enmSortOrder)
'//return count of found files
Execute = mlngFileCount
End Function
Private Sub FindFiles(ByVal strFolderPath As String)
Dim udtWFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & "*.*", udtWFD)
If lngSearch <> INVALID_HANDLE_VALUE Then
Call GetFilesInFolder(strFolderPath)
If mblnSubFolders Then
Do
If (udtWFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
strDirName = Left$(udtWFD.cFileName & vbNullChar, InStr(udtWFD.cFileName, vbNullChar) - 1)
If (strDirName <> ".") And (strDirName <> "..") Then _
Call FindFiles(strFolderPath & strDirName)
End If
Loop While FindNextFile(lngSearch, udtWFD)
End If
Call FindClose(lngSearch)
End If
End Sub
Private Sub GetFilesInFolder(ByVal strFolderPath As String)
Dim udtWFD As WIN32_FIND_DATA, lngSearch As Long, strFilename As String
Dim udtFiletime As FILETIME, udtSystemtime As SYSTEMTIME
If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & mstrExtension, udtWFD)
If lngSearch <> INVALID_HANDLE_VALUE Then
Do
If (udtWFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
strFilename = Left$(udtWFD.cFileName & vbNullChar, InStr(udtWFD.cFileName, vbNullChar) - 1)
If mstrSearchLike <> "" Then If Not IIf(mblnCaseSenstiv, strFilename, LCase$(strFilename)) Like _
IIf(mblnCaseSenstiv, mstrSearchLike, LCase$(mstrSearchLike)) Then GoTo next_file
If mstrNotSearchLike <> "" Then If IIf(mblnCaseSenstiv, strFilename, LCase$(strFilename)) Like _
IIf(mblnCaseSenstiv, mstrNotSearchLike, LCase$(mstrNotSearchLike)) Then GoTo next_file
mlngFileCount = mlngFileCount + 1
Redim Preserve mudtFiles(1 To mlngFileCount)
With mudtFiles(mlngFileCount)
.strPath = strFolderPath & strFilename
.strFilename = strFilename
.lngSize = udtWFD.nFileSizeLow
FileTimeToLocalFileTime udtWFD.ftCreationTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.dmtDateCreate = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
FileTimeToLocalFileTime udtWFD.ftLastAccessTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.dmtLastAccess = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
FileTimeToLocalFileTime udtWFD.ftLastWriteTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.dmtLastModify = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
End With
next_file:
End If
Loop While FindNextFile(lngSearch, udtWFD)
Call FindClose(lngSearch)
End If
End Sub
Private Sub QuickSort(lngLBorder As Long, lngUBorder As Long, enmSortBy As SORT_BY, enmSortOrder As SORT_ORDER)
Dim lngIndex1 As Long, lngIndex2 As Long
Dim udtBuffer As FILEINFO, vntTemp As Variant
lngIndex1 = lngLBorder
lngIndex2 = lngUBorder
Select Case enmSortBy
Case Sort_by_Name: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).strFilename
Case Sort_by_Path: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).strPath
Case Sort_by_Size: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).lngSize
Case Sort_by_Last_Access: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtLastAccess
Case Sort_by_Last_Modyfy: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtLastModify
Case Sort_by_Date_Create: vntTemp = mudtFiles((lngLBorder + lngUBorder) \ 2).dmtDateCreate
End Select
Do
Select Case enmSortBy
Case Sort_by_Name
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).strFilename < vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp < mudtFiles(lngIndex2).strFilename
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While mudtFiles(lngIndex1).strFilename > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).strFilename
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Path
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).strPath < vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp < mudtFiles(lngIndex2).strPath
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While mudtFiles(lngIndex1).strPath > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).strPath
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Size
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).lngSize < vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp < mudtFiles(lngIndex2).lngSize
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While mudtFiles(lngIndex1).lngSize > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).lngSize
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Last_Access
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).dmtLastAccess < vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp < mudtFiles(lngIndex2).dmtLastAccess
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While mudtFiles(lngIndex1).dmtLastAccess > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).dmtLastAccess
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Last_Modyfy
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).dmtLastModify < vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp < mudtFiles(lngIndex2).dmtLastModify
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While mudtFiles(lngIndex1).dmtLastModify > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).dmtLastModify
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Date_Create
If enmSortOrder = Sort_Order_Ascending Then
Do While mudtFiles(lngIndex1).dmtDateCreate < vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp < mudtFiles(lngIndex2).dmtDateCreate
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While mudtFiles(lngIndex1).dmtDateCreate > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > mudtFiles(lngIndex2).dmtDateCreate
lngIndex2 = lngIndex2 - 1
Loop
End If
End Select
If lngIndex1 <= lngIndex2 Then
udtBuffer = mudtFiles(lngIndex1)
mudtFiles(lngIndex1) = mudtFiles(lngIndex2)
mudtFiles(lngIndex2) = udtBuffer
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
End If
Loop Until lngIndex1 > lngIndex2
If lngLBorder < lngIndex2 Then Call QuickSort(lngLBorder, lngIndex2, enmSortBy, enmSortOrder)
If lngIndex1 < lngUBorder Then Call QuickSort(lngIndex1, lngUBorder, enmSortBy, enmSortOrder)
End Sub
Bietet sogar etwas mehr Funktionen wie das ursprüngliche FileSearch-Objekt.
Gruß
Nepumuk