das geht z. B. so.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Declare Function SHGetFileInfo Lib "Shell32" Alias "SHGetFileInfoA" (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Const MAX_PATH = 260
Const SHGFI_TYPENAME = &H400&
Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
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
Dim strRoot As String
Dim vntResult() As Variant
strRoot = fncBrowseForFolder
If strRoot = "" Then Exit Sub
Set objFileSearch = New clsFileSearch
With objFileSearch
.CaseSenstiv = True
.Extension = "*.*"
.FolderPath = strRoot
.SearchLike = "*"
.SubFolders = True
If .Execute() > 0 Then
Redim vntResult(1 To .FileCount, 1 To 6)
For lngIndex = 1 To .FileCount
vntResult(lngIndex, 1) = Left(.Files(lngIndex).strFilename, InStr(1, .Files(lngIndex).strFilename, ".") - 1)
vntResult(lngIndex, 2) = GetTypeName(.Files(lngIndex).strPath)
vntResult(lngIndex, 3) = Mid(.Files(lngIndex).strFilename, InStr(1, .Files(lngIndex).strFilename, ".") + 1)
vntResult(lngIndex, 4) = Round(.Files(lngIndex).lngSize / 1024 / 1024, 2)
vntResult(lngIndex, 5) = .Files(lngIndex).dmtDateCreate
vntResult(lngIndex, 6) = Left(.Files(lngIndex).strPath, InStrRev(.Files(lngIndex).strPath, "\") - 1)
Next
End If
End With
Set objFileSearch = Nothing
End Sub
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function
Private Function GetTypeName(sFilePath As String)
Dim shfi As SHFILEINFO
If SHGetFileInfo(ByVal sFilePath, 0&, shfi, Len(shfi), SHGFI_TYPENAME) Then
If InStr(shfi.szTypeName, vbNullChar) > 1 Then
GetTypeName = Left$(shfi.szTypeName, InStr(shfi.szTypeName, Chr(0)) - 1)
Else
GetTypeName = "<keinem Dateityp zugeordnet>"
End If
End If
End Function
' **********************************************************************
' Modul: clsFileSearch Typ: Klassenmodul
' **********************************************************************
'// Module : clsFileSearch, Klassenmodul
'// Author : NEPUMUK at http://www.office-loesung.de/ftopic148247_0_0_asc.php
'// Created : 28. Mai 2007
'// Modified :
'// Purpose : FileSearch
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 mblnSubFolders As Boolean
Private mblnCaseSenstiv As Boolean
Friend Property Get Files(lngIndex As Long) As FILEINFO
Files = mudtFiles(lngIndex)
End Property
Friend Property Get FileCount() As Long
FileCount = mlngFileCount
End Property
Friend Property Let FolderPath(strFolderPath As String)
mstrFolderPath = strFolderPath
End Property
Friend Property Let Extension(strExtension As String)
mstrExtension = strExtension
End Property
Friend Property Let SearchLike(strSearchLike As String)
mstrSearchLike = strSearchLike
End Property
Friend Property Let SubFolders(blnSubFolders As Boolean)
mblnSubFolders = blnSubFolders
End Property
Friend Property Let CaseSenstiv(blnCaseSenstiv As Boolean)
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
Call FindFiles(mstrFolderPath)
If mlngFileCount > 1 And enmSortBy <> Sort_by_None Then _
Call prcSort(1, mlngFileCount, enmSortBy, enmSortOrder)
Execute = mlngFileCount
End Function
Private Sub FindFiles(ByVal strFolderPath As String)
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
On Error GoTo ErrorHandling
If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
If lngSearch <> INVALID_HANDLE_VALUE Then
Call GetFilesInFolder(strFolderPath)
If mblnSubFolders Then
Do
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
If (strDirName <> ".") And (strDirName <> "..") Then _
Call FindFiles(strFolderPath & strDirName)
End If
Loop While FindNextFile(lngSearch, WFD)
End If
FindClose lngSearch
End If
Exit Sub
ErrorHandling:
MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehler"
End Sub
Private Sub GetFilesInFolder(ByVal strFolderPath As String)
Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFilename As String
Dim udtFiletime As FILETIME, udtSystemtime As SYSTEMTIME
On Error GoTo ErrorHandling
If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & mstrExtension, WFD)
If lngSearch <> INVALID_HANDLE_VALUE Then
Do
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
strFilename = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)) - 1)
If IIf(mblnCaseSenstiv, strFilename, LCase$(strFilename)) Like _
IIf(mblnCaseSenstiv, mstrSearchLike, LCase$(mstrSearchLike)) Then
mlngFileCount = mlngFileCount + 1
Redim Preserve mudtFiles(1 To mlngFileCount)
With mudtFiles(mlngFileCount)
.strPath = strFolderPath & strFilename
.strFilename = strFilename
.lngSize = WFD.nFileSizeLow
FileTimeToLocalFileTime WFD.ftCreationTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.dmtDateCreate = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
FileTimeToLocalFileTime WFD.ftLastAccessTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.dmtLastAccess = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
FileTimeToLocalFileTime WFD.ftLastWriteTime, udtFiletime
FileTimeToSystemTime udtFiletime, udtSystemtime
.dmtLastModify = CDate(DateSerial(udtSystemtime.wYear, udtSystemtime.wMonth, udtSystemtime.wDay) + _
TimeSerial(udtSystemtime.wHour, udtSystemtime.wMinute, udtSystemtime.wSecond))
End With
End If
End If
Loop While FindNextFile(lngSearch, WFD)
FindClose lngSearch
End If
Exit Sub
ErrorHandling:
MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehler"
End Sub
Private Sub prcSort(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 prcSort(lngLBorder, lngIndex2, enmSortBy, enmSortOrder)
If lngIndex1 < lngUBorder Then Call prcSort(lngIndex1, lngUBorder, enmSortBy, enmSortOrder)
End Sub