AW: Do Loop auf 64 Bit bricht ab
23.01.2023 18:18:15
max.kaffl@gmx.de
Hallo Stanislaus,
das läuft in beiden Versionen:
Option Explicit
Option Compare Text
#If Win64 Then
Private Declare PtrSafe Function FindFirstFileA Lib "kernel32.dll" ( _
ByVal lpFileName As String, _
ByRef lpFindFileData As WIN32_FIND_DATA) As LongPtr
Private Declare PtrSafe Function FindNextFileA Lib "kernel32.dll" ( _
ByVal hFindFile As LongPtr, _
ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare PtrSafe Function FindClose Lib "kernel32.dll" ( _
ByVal hFindFile As LongPtr) As Long
Private Declare PtrSafe Function FileTimeToLocalFileTime Lib "kernel32.dll" ( _
ByRef lpFileTime As FILETIME, _
ByRef lpLocalFileTime As FILETIME) As Long
Private Declare PtrSafe Function FileTimeToSystemTime Lib "kernel32.dll" ( _
ByRef lpFileTime As FILETIME, _
ByRef lpSystemTime As SYSTEMTIME) As Long
#Else
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 Declare Function FindClose Lib "kernel32.dll" ( _
ByVal hFindFile As Long) As Long
Private Declare Function FindFirstFileA Lib "kernel32.dll" ( _
ByVal lpFileName As String, _
ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFileA Lib "kernel32.dll" ( _
ByVal hFindFile As Long, _
ByRef lpFindFileData As WIN32_FIND_DATA) As Long
#End If
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 As Long = 260&
#If Win64 Then
Private Const INVALID_HANDLE_VALUE As LongPtr = -1
#Else
Private Const INVALID_HANDLE_VALUE As Long = -1&
#End If
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 maudtFiles() As FILEINFO
Private mlngFileCount As Long
Private mstrFolderPath As String
Private mstrExtension As String
Private mstrSearchLike As String
Private mblnSubFolders As Boolean
Private mblnCaseSenstiv As Boolean
Private mblnNewSearch As Boolean
Friend Property Get Files(ByVal pvlngIndex As Long) As FILEINFO
Files = maudtFiles(pvlngIndex)
End Property
Friend Property Let Files(ByVal pvlngIndex As Long, ByRef prudtFileInfo As FILEINFO)
maudtFiles(pvlngIndex) = prudtFileInfo
End Property
Friend Property Get FileCount() As Long
FileCount = mlngFileCount
End Property
Friend Property Let FileCount(ByVal pvlngFileCount As Long)
mlngFileCount = pvlngFileCount
End Property
Friend Property Get FolderPath() As String
FolderPath = mstrFolderPath
End Property
Friend Property Let FolderPath(ByVal pvstrFolderPath As String)
mstrFolderPath = pvstrFolderPath
End Property
Friend Property Get Extension() As String
Extension = mstrExtension
End Property
Friend Property Let Extension(ByVal pvstrExtension As String)
mstrExtension = pvstrExtension
End Property
Friend Property Get SearchLike() As String
SearchLike = mstrSearchLike
End Property
Friend Property Let SearchLike(ByVal pvstrSearchLike As String)
mstrSearchLike = pvstrSearchLike
End Property
Friend Property Get SubFolders() As Boolean
SubFolders = mblnSubFolders
End Property
Friend Property Let SubFolders(ByVal pvblnSubFolders As Boolean)
mblnSubFolders = pvblnSubFolders
End Property
Friend Property Get CaseSenstiv() As Boolean
CaseSenstiv = mblnCaseSenstiv
End Property
Friend Property Let CaseSenstiv(ByVal pvblnCaseSenstiv As Boolean)
mblnCaseSenstiv = pvblnCaseSenstiv
End Property
Friend Property Get NewSearch() As Boolean
NewSearch = mblnNewSearch
End Property
Friend Property Let NewSearch(ByVal pvblnNewSearch As Boolean)
mblnNewSearch = pvblnNewSearch
End Property
Friend Function Execute(Optional ByVal opvenmSortBy As SORT_BY = Sort_by_None, _
Optional ByVal opvenmSortOrder As SORT_ORDER = Sort_Order_Ascending) As Long
If NewSearch Then FileCount = 0
Call FindFiles(FolderPath)
If FileCount > 1 And opvenmSortBy > Sort_by_None Then _
Call QuickSort(1, FileCount, opvenmSortBy, opvenmSortOrder)
Execute = FileCount
End Function
Private Sub FindFiles(ByVal pvstrFolderPath As String)
#If Win64 Then
Dim lngSearch As LongPtr
#Else
Dim lngSearch As Long
#End If
Dim udtWFD As WIN32_FIND_DATA
Dim strDirName As String
On Error GoTo ErrorHandling
If Right$(pvstrFolderPath, 1) > "\" Then pvstrFolderPath = pvstrFolderPath & "\"
lngSearch = FindFirstFileA(pvstrFolderPath & "*.*", udtWFD)
If lngSearch > INVALID_HANDLE_VALUE Then
Call GetFilesInFolder(pvstrFolderPath)
If SubFolders Then
Do
If (udtWFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
strDirName = Left$(udtWFD.cFileName, InStr(udtWFD.cFileName, vbNullChar) - 1)
If (strDirName > ".") And (strDirName > "..") Then _
Call FindFiles(pvstrFolderPath & strDirName)
End If
Loop While FindNextFileA(lngSearch, udtWFD)
End If
Call FindClose(lngSearch)
End If
Exit Sub
ErrorHandling:
Call MsgBox("Fehler " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehler")
End Sub
Private Sub GetFilesInFolder(ByVal pvstrFolderPath As String)
#If Win64 Then
Dim lngSearch As LongPtr
#Else
Dim lngSearch As Long
#End If
Dim udtWFD As WIN32_FIND_DATA
Dim strFilename As String
Dim udtFiletime As FILETIME, udtSystemtime As SYSTEMTIME, udtTempFile As FILEINFO
On Error GoTo ErrorHandling
If Right$(pvstrFolderPath, 1) > "\" Then pvstrFolderPath = pvstrFolderPath & "\"
lngSearch = FindFirstFileA(pvstrFolderPath & Extension, udtWFD)
If lngSearch > INVALID_HANDLE_VALUE Then
Do
If (udtWFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) > FILE_ATTRIBUTE_DIRECTORY Then
strFilename = Left$(udtWFD.cFileName, InStr(udtWFD.cFileName, vbNullChar) - 1)
If IIf(CaseSenstiv, strFilename, LCase$(strFilename)) Like _
IIf(CaseSenstiv, SearchLike, LCase$(SearchLike)) Then
With udtTempFile
.Path = pvstrFolderPath & strFilename
.Filename = strFilename
.Size = udtWFD.nFileSizeLow
End With
Call FileTimeToLocalFileTime(udtWFD.ftCreationTime, udtFiletime)
Call FileTimeToSystemTime(udtFiletime, udtSystemtime)
With udtSystemtime
udtTempFile.DateCreate = CDate(DateSerial(.wYear, .wMonth, .wDay) + _
TimeSerial(.wHour, .wMinute, .wSecond))
End With
Call FileTimeToLocalFileTime(udtWFD.ftLastAccessTime, udtFiletime)
Call FileTimeToSystemTime(udtFiletime, udtSystemtime)
With udtSystemtime
udtTempFile.LastAccess = CDate(DateSerial(.wYear, .wMonth, .wDay) + _
TimeSerial(.wHour, .wMinute, .wSecond))
End With
Call FileTimeToLocalFileTime(udtWFD.ftLastWriteTime, udtFiletime)
Call FileTimeToSystemTime(udtFiletime, udtSystemtime)
With udtSystemtime
udtTempFile.LastModify = CDate(DateSerial(.wYear, .wMonth, .wDay) + _
TimeSerial(.wHour, .wMinute, .wSecond))
End With
FileCount = FileCount + 1
ReDim Preserve maudtFiles(1 To FileCount)
Files(FileCount) = udtTempFile
End If
End If
Loop While FindNextFileA(lngSearch, udtWFD)
Call FindClose(lngSearch)
End If
Exit Sub
ErrorHandling:
Call MsgBox("Fehler " & CStr(Err.Number) & vbLf & vbLf & _
Err.Description, vbCritical, "Fehler")
End Sub
Private Sub QuickSort(ByVal pvlngLBorder As Long, ByVal pvlngUBorder As Long, _
ByVal pvenmSortBy As SORT_BY, ByVal pvenmSortOrder As SORT_ORDER)
Dim lngIndex1 As Long, lngIndex2 As Long
Dim udtBuffer As FILEINFO
Dim vntTemp As Variant
lngIndex1 = pvlngLBorder
lngIndex2 = pvlngUBorder
Select Case pvenmSortBy
Case Sort_by_Name
vntTemp = Files((pvlngLBorder + pvlngUBorder) \ 2).Filename
Case Sort_by_Path
vntTemp = Files((pvlngLBorder + pvlngUBorder) \ 2).Path
Case Sort_by_Size
vntTemp = Files((pvlngLBorder + pvlngUBorder) \ 2).Size
Case Sort_by_Last_Access
vntTemp = Files((pvlngLBorder + pvlngUBorder) \ 2).LastAccess
Case Sort_by_Last_Modyfy
vntTemp = Files((pvlngLBorder + pvlngUBorder) \ 2).LastModify
Case Sort_by_Date_Create
vntTemp = Files((pvlngLBorder + pvlngUBorder) \ 2).DateCreate
End Select
Do
Select Case pvenmSortBy
Case Sort_by_Name
If pvenmSortOrder = Sort_Order_Ascending Then
Do While Files(lngIndex1).Filename vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp Files(lngIndex2).Filename
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While Files(lngIndex1).Filename > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > Files(lngIndex2).Filename
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Path
If pvenmSortOrder = Sort_Order_Ascending Then
Do While Files(lngIndex1).Path vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp Files(lngIndex2).Path
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While Files(lngIndex1).Path > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > Files(lngIndex2).Path
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Size
If pvenmSortOrder = Sort_Order_Ascending Then
Do While Files(lngIndex1).Size vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp Files(lngIndex2).Size
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While Files(lngIndex1).Size > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > Files(lngIndex2).Size
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Last_Access
If pvenmSortOrder = Sort_Order_Ascending Then
Do While Files(lngIndex1).LastAccess vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp Files(lngIndex2).LastAccess
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While Files(lngIndex1).LastAccess > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > Files(lngIndex2).LastAccess
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Last_Modyfy
If pvenmSortOrder = Sort_Order_Ascending Then
Do While Files(lngIndex1).LastModify vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp Files(lngIndex2).LastModify
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While Files(lngIndex1).LastModify > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > Files(lngIndex2).LastModify
lngIndex2 = lngIndex2 - 1
Loop
End If
Case Sort_by_Date_Create
If pvenmSortOrder = Sort_Order_Ascending Then
Do While Files(lngIndex1).DateCreate vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp Files(lngIndex2).DateCreate
lngIndex2 = lngIndex2 - 1
Loop
Else
Do While Files(lngIndex1).DateCreate > vntTemp
lngIndex1 = lngIndex1 + 1
Loop
Do While vntTemp > Files(lngIndex2).DateCreate
lngIndex2 = lngIndex2 - 1
Loop
End If
End Select
If lngIndex1 = lngIndex2 Then
udtBuffer = Files(lngIndex1)
Files(lngIndex1) = Files(lngIndex2)
Files(lngIndex2) = udtBuffer
lngIndex1 = lngIndex1 + 1
lngIndex2 = lngIndex2 - 1
End If
Loop Until lngIndex1 > lngIndex2
If pvlngLBorder lngIndex2 Then Call QuickSort(pvlngLBorder, lngIndex2, pvenmSortBy, pvenmSortOrder)
If lngIndex1 pvlngUBorder Then Call QuickSort(lngIndex1, pvlngUBorder, pvenmSortBy, pvenmSortOrder)
End Sub
Gruß
Nepumuk