Moin Christian, :-)
… doch
überlegt, ob ich das
poste. ;-)
Ob du es glaubst oder nicht. Mit
API kannst du sogar
Kaffee kochen. Früher habe ich die
RS232 COM-Schnittstelle abfragen/steuern müssen (
heute dann USB). ;-)
Ich höre schon wieder das "
Gemecker" - äähh
Entschuldigung den "
Einwand" - wo ist #If Win64 then…
Selbst ist der Mann(
Frau, Es), wenn er (s
ie, es) 32 Bit will (
so viel schaffe ich nicht - da kippe ich vorher um). ;-)
Spaß beiseite (
aber Kaffee kochen geht wirklich) - ich höre schon deine Frage: "
Ups, das sind aber viele Zeilen Code?" ;-)
Ja - man könnte es kürzen (
z. B. mit Private Declare PtrSafe Function EnumDirTreeW Lib "Dbghelp.dll") - aber darauf habe ich keinen Bock. ;-)
Zumal FindFirstFile/FindNextFile auf meiner "
Möhre" so schnell läuft, dass ich die Arschbacken nicht zusammenkneifen kann - schon ist es fertig - unter
0,0Irgenwas Sekunden. ;-)
Ich habe in meinen MZ-Tools so viele Beispiele. Ich teste nur noch - geht es - dann ist gut. ;-)
Warum braucht API "
so viele" Zeilen gegenüber z. B. WScript.Shell? ;-)
Erklärungsversuch: ;-)
WScript.Shell ist - zumindest bei mir - nicht nur beim ersten Start, da aber besonders - ziemlich langsam. ;-)
WScript.Shell ist
bequem, aber
nicht kostenlos. ;-)
Beim ersten Start wird erst der COM-Wrapper
initialisiert, was spürbar Zeit kostet. ;-)
Direkte API-Aufrufe sind zwar
deutlich ausführlicher,
umgehen aber diese zusätzliche Schicht. ;-)
Oder noch anders ausgedrückt: ;-)
Die 50 (
oder mehr) zusätzlichen Zeilen sind im Prinzip das, was WScript.Shell intern sowieso macht - nur diesmal
ohne Warmhalteplatte, COM-Küche und Skript-Butler davor. ;-)
Mit
API-Code stehst du praktisch direkt an der "
Werkbank von Windows". Du programmierst
SEHR Betriebssystemnah. ;-)
So - dann habe ich angefangen den Code zu kommentieren. Darauf hatte ich dann nach
2,3 Zeilen keine Lust mehr. Also habe ich die
KI gefragt. Mach mir Kommentare mit Links zu den APIs. ;-)
Ich
tendiere ja dazu -
keine Leerzeilen,
keine Umbrüche. Das ist
IMHO unübersichtlich. ;-)
Habe dann zur KI etwa sowas gesagt: ;-)
"
Bei mir stellen sich bei Leerzeilen die "Nackenhaare" - ich warte dann immer auf den Schlüsselbund unseres Programmierlehrers (aus den 80gern). Und Umbrüche mache ich grundsätzlich nicht, da ich ja nicht mehr mit einem 15-Zoll-Belinea-Monitor arbeite. Heute arbeitet doch jeder mit 2 oder 3 großen Monitoren - oder mit einem Curved-Monitor, der fast so groß ist, wie der Schreibtisch (wenn man sich nicht gerade den Eichenschreibtisch vom Opa "organisiert" hat)". ;-)
Die KI hat trotzdem mit viel
Leerzeilen gearbeitet - und
Umbrüchen. ;.)
Du bekommst also erst meine Version: ;-)
Ein Beispiel daraus: ;-)
strRoot = fncGetDLFolder() 'Environ$("USERPROFILE") & "\Downloads"
Privat wirst du ja Downloads
nicht umbenennen bzw. es ist
nicht über OneDrive geleitet.
Dann kannst du mit
Environ$("USERPROFILE") & "\Downloads" arbeiten. Schon sind wieder
einige Zeilen weg. ;-)
Den habe ich getestet (
sind nur ein paar Kommentare drin): ;-)
Option Explicit
' https://learn.microsoft.com/de-de/windows/win32/api/winbase/nf-winbase-formatmessagew
' Windows-Fehlercode in lesbare Textmeldung umwandeln.
Private Declare PtrSafe Function FormatMessage Lib "kernel32" Alias "FormatMessageW" (ByVal dwFlags As Long, ByVal lpSource As LongPtr, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As LongPtr, ByVal nSize As Long, ByVal Arguments As LongPtr) As Long
'https://learn.microsoft.com/de-de/windows/win32/api/winbase/nf-winbase-movefileexw
' Verschieben/Umbenennen von Dateien/Verzeichnissen Mit untergeordneten Elementen und Rückrufauswertung.
Private Declare PtrSafe Function MoveFileEx Lib "kernel32" Alias "MoveFileExW" (ByVal lpExistingFileName As LongPtr, ByVal lpNewFileName As LongPtr, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function SHGetKnownFolderPath Lib "shell32" (ByRef rfid As GUID, ByVal dwFlags As Long, ByVal hToken As LongPtr, ByRef pszPath As LongPtr) As Long
Private Declare PtrSafe Function FindFirstFile Lib "kernel32" Alias "FindFirstFileW" (ByVal lpFileName As LongPtr, lpFindFileData As WIN_FIND_DATA) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Long)
Private Declare PtrSafe Function FindNextFile Lib "kernel32" Alias "FindNextFileW" (ByVal hFindFile As LongPtr, lpFindFileData As WIN_FIND_DATA) As Long
Private Declare PtrSafe Function FindClose Lib "kernel32" (ByVal hFindFile As LongPtr) As Long
Private Declare PtrSafe Function lstrlenW Lib "kernel32" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal pv As LongPtr)
Private Declare PtrSafe Function GetLastError Lib "kernel32" () As Long
'https://learn.microsoft.com/de-de/office/vba/language/reference/user-interface-help/type-statement
' Type - Auf Modulebene um um einen benutzerdefinierten Datentyp zu definieren, der ein oder mehrere Elemente enthält.
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN_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(0 To 259) As Integer
cAlternate(0 To 13) As Integer
End Type
' Was soll passieren, wenn nichts gefunden wird.
Private Const HANDLE_EMPTY As LongPtr = -1
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
Private Type tTopFile
FilePath As String
FileSize As Double
ft As FILETIME
End Type
Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Const MOVEFILE_REPLACE_EXISTING As Long = &H1
Private Const strEX As String = ".csv"
Private TopFiles(1 To 3) As tTopFile
Private blnRecursive As Boolean
Public Sub Main_3_CSV()
Dim strTarget As String
Dim strRoot As String
Dim lngCount As Long
Dim lngErr As Long
' Environ$ versagt, wenn Downloads umbenannt oder umgeleitet wurde - deshalb API.
strRoot = fncGetDLFolder() 'Environ$("USERPROFILE") & "\Downloads"
' False = UNTERORDNER WERDEN NICHT DURCHSUCHT
' True = UNTERORDNER WERDEN DURCHSUCHT
blnRecursive = False
' Unbedingt, sonst werden falsche Dateien ausgegeben!
InitTopFiles
SearchFolderRecursive strRoot
Call SortTop3BySize
For lngCount = 1 To 3
If Len(TopFiles(lngCount).FilePath) > 0 Then
strTarget = strRoot & "\L" & lngCount & strEX
If MoveFileEx(StrPtr(TopFiles(lngCount).FilePath), StrPtr(strTarget), MOVEFILE_REPLACE_EXISTING) = 0 Then
lngErr = GetLastError()
MsgBox "Fehler beim Umbenennen:" & vbCrLf & TopFiles(lngCount).FilePath & vbCrLf & "-> " & strTarget & vbCrLf & vbCrLf & GetWinError(lngErr), vbCritical
End If
End If
Next lngCount
End Sub
Private Sub InitTopFiles()
Erase TopFiles
End Sub
Private Sub SortTop3BySize()
Dim lngBubA As Long
Dim lngBubB As Long
Dim tmp As tTopFile
For lngBubA = 1 To 2
For lngBubB = lngBubA + 1 To 3
If TopFiles(lngBubB).FileSize > TopFiles(lngBubA).FileSize Then
tmp = TopFiles(lngBubA)
TopFiles(lngBubA) = TopFiles(lngBubB)
TopFiles(lngBubB) = tmp
End If
Next lngBubB
Next lngBubA
End Sub
Private Sub SearchFolderRecursive(ByVal strFolder As String)
Dim wfd As WIN_FIND_DATA
Dim strSearch As String
Dim lngpFind As LongPtr
Dim strName As String
Dim strFull As String
strSearch = strFolder & "\*"
lngpFind = FindFirstFile(StrPtr(strSearch), wfd)
If lngpFind = HANDLE_EMPTY Then
Debug.Print "Keine Dateien gefunden."
Else
Do
strName = fncPtrToString(wfd.cFileName)
If strName <> "." And strName <> ".." Then
strFull = strFolder & "\" & strName
If (wfd.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> 0 Then
If blnRecursive Then SearchFolderRecursive strFull
Else
If LCase$(Right$(strName, 4)) = strEX Then
fncCheckTop3 strFull, wfd
End If
End If
End If
Loop While FindNextFile(lngpFind, wfd)
End If
FindClose lngpFind
End Sub
Private Function fncGetDLFolder() As String
Dim FOLDERID_Downloads As GUID
Dim lngpPath As LongPtr
Dim strPath As String
Dim lngLen As Long
With FOLDERID_Downloads
.Data1 = &H374DE290
.Data2 = &H123F
.Data3 = &H4565
.Data4(0) = &H91
.Data4(1) = &H64
.Data4(2) = &H39
.Data4(3) = &HC4
.Data4(4) = &H92
.Data4(5) = &H5E
.Data4(6) = &H46
.Data4(7) = &H7B
End With
If SHGetKnownFolderPath(FOLDERID_Downloads, 0, 0, lngpPath) = 0 Then
lngLen = lstrlenW(lngpPath)
strPath = String$(lngLen, vbNullChar)
CopyMemory StrPtr(strPath), lngpPath, lngLen * 2
CoTaskMemFree lngpPath
fncGetDLFolder = strPath
End If
End Function
Private Sub fncCheckTop3(ByVal strFile As String, ByRef wfd As WIN_FIND_DATA)
If CompareFileTime(wfd.ftLastWriteTime, TopFiles(1).ft) Then
TopFiles(3) = TopFiles(2)
TopFiles(2) = TopFiles(1)
FillTopFile TopFiles(1), strFile, wfd
ElseIf CompareFileTime(wfd.ftLastWriteTime, TopFiles(2).ft) Then
TopFiles(3) = TopFiles(2)
FillTopFile TopFiles(2), strFile, wfd
ElseIf CompareFileTime(wfd.ftLastWriteTime, TopFiles(3).ft) Then
FillTopFile TopFiles(3), strFile, wfd
End If
End Sub
Private Sub FillTopFile(ByRef t As tTopFile, ByVal strFile As String, ByRef wfd As WIN_FIND_DATA)
t.FilePath = strFile
t.FileSize = CDbl(wfd.nFileSizeHigh) * 4294967296# + wfd.nFileSizeLow
t.ft = wfd.ftLastWriteTime
End Sub
Private Function CompareFileTime(a As FILETIME, b As FILETIME) As Boolean
If a.dwHighDateTime > b.dwHighDateTime Then
CompareFileTime = True
ElseIf a.dwHighDateTime < b.dwHighDateTime Then
CompareFileTime = False
Else
CompareFileTime = (a.dwLowDateTime > b.dwLowDateTime)
End If
End Function
Private Function fncPtrToString(intArr() As Integer) As String
Dim strTemp As String
Dim lngCount As Long
For lngCount = LBound(intArr) To UBound(intArr)
If intArr(lngCount) = 0 Then Exit For
strTemp = strTemp & ChrW$(intArr(lngCount))
Next lngCount
fncPtrToString = strTemp
End Function
Private Function GetWinError(ByVal lngErr As Long) As String
Dim strBuf As String
Dim lngRet As Long
strBuf = String$(512, vbNullChar)
lngRet = FormatMessage( _
FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0, lngErr, 0, StrPtr(strBuf), 512, 0)
If lngRet > 0 Then
GetWinError = Left$(strBuf, lngRet)
Else
GetWinError = "Unbekannter Fehlercode: " & lngErr
End If
End Function
Nun der
kommentierte Code der
KI (
den habe ich NICHT getestet): ;-)
Option Explicit
' ============================================================
' Windows API: FormatMessageW
' https://learn.microsoft.com/de-de/windows/win32/api/winbase/nf-winbase-formatmessagew
' Wandelt einen Windows-Fehlercode in eine lesbare Textmeldung um.
' Wird typischerweise für GetLastError-Auswertung genutzt.
' ============================================================
Private Declare PtrSafe Function FormatMessage Lib "kernel32" Alias "FormatMessageW" ( _
ByVal dwFlags As Long, _
ByVal lpSource As LongPtr, _
ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, _
ByVal lpBuffer As LongPtr, _
ByVal nSize As Long, _
ByVal Arguments As LongPtr) As Long
' ============================================================
' Windows API: MoveFileExW
' https://learn.microsoft.com/de-de/windows/win32/api/winbase/nf-winbase-movefileexw
' Verschiebt oder benennt Dateien/Ordner um.
' Unterstützt Flags wie Überschreiben oder verzögertes Verschieben.
' ============================================================
Private Declare PtrSafe Function MoveFileEx Lib "kernel32" Alias "MoveFileExW" ( _
ByVal lpExistingFileName As LongPtr, _
ByVal lpNewFileName As LongPtr, _
ByVal dwFlags As Long) As Long
' ============================================================
' Windows API: SHGetKnownFolderPath
' https://learn.microsoft.com/de-de/windows/win32/api/shlobj_core/nf-shlobj_core-shgetknownfolderpath
' Liefert Pfade zu bekannten Windows-Ordnern (z. B. Downloads, Desktop).
' ============================================================
Private Declare PtrSafe Function SHGetKnownFolderPath Lib "shell32" ( _
ByRef rfid As GUID, _
ByVal dwFlags As Long, _
ByVal hToken As LongPtr, _
ByRef pszPath As LongPtr) As Long
' ============================================================
' Windows API: FindFirstFileW
' https://learn.microsoft.com/de-de/windows/win32/api/fileapi/nf-fileapi-findfirstfilew
' Startet eine Dateisuche in einem Verzeichnis (*.* Pattern).
' ============================================================
Private Declare PtrSafe Function FindFirstFile Lib "kernel32" Alias "FindFirstFileW" ( _
ByVal lpFileName As LongPtr, _
lpFindFileData As WIN_FIND_DATA) As LongPtr
' ============================================================
' Windows API: RtlMoveMemory (CopyMemory)
' https://learn.microsoft.com/de-de/windows/win32/api/winbase/nf-winbase-rtlmovememory
' Kopiert Speicherblöcke zwischen Pointer-Adressen.
' Wird hier zum Konvertieren von Strings aus API-Pointern genutzt.
' ============================================================
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByVal Destination As LongPtr, _
ByVal Source As LongPtr, _
ByVal Length As Long)
' ============================================================
' Windows API: FindNextFileW
' https://learn.microsoft.com/de-de/windows/win32/api/fileapi/nf-fileapi-findnextfilew
' Setzt eine gestartete Dateisuche fort (nächster Treffer).
' ============================================================
Private Declare PtrSafe Function FindNextFile Lib "kernel32" Alias "FindNextFileW" ( _
ByVal hFindFile As LongPtr, _
lpFindFileData As WIN_FIND_DATA) As Long
' ============================================================
' Windows API: FindClose
' https://learn.microsoft.com/de-de/windows/win32/api/fileapi/nf-fileapi-findclose
' Schließt einen offenen Such-Handle einer Dateisuche.
' ============================================================
Private Declare PtrSafe Function FindClose Lib "kernel32" ( _
ByVal hFindFile As LongPtr) As Long
' ============================================================
' Windows API: lstrlenW
' https://learn.microsoft.com/de-de/windows/win32/api/stringapiset/nf-stringapiset-lstrlenw
' Ermittelt die Länge eines Unicode-Strings (Null-terminiert).
' ============================================================
Private Declare PtrSafe Function lstrlenW Lib "kernel32" ( _
ByVal lpString As LongPtr) As Long
' ============================================================
' Windows API: CoTaskMemFree
' https://learn.microsoft.com/de-de/windows/win32/api/combaseapi/nf-combaseapi-cotaskmemfree
' Gibt Speicher frei, der von COM-APIs reserviert wurde.
' ============================================================
Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32" ( _
ByVal pv As LongPtr)
' ============================================================
' Windows API: GetLastError
' https://learn.microsoft.com/de-de/windows/win32/api/errhandlingapi/nf-errhandlingapi-getlasterror
' Liefert den letzten Windows-Fehlercode der API-Aufrufe.
' ============================================================
Private Declare PtrSafe Function GetLastError Lib "kernel32" () As Long
' ============================================================
' Type: GUID
' https://learn.microsoft.com/de-de/windows/win32/api/guiddef/ns-guiddef-guid
' Struktur zur Identifikation von Windows-Systemobjekten.
' ============================================================
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
' ============================================================
' Type: FILETIME
' https://learn.microsoft.com/de-de/windows/win32/api/minwinbase/ns-minwinbase-filetime
' Speichert Zeitstempel in Windows-API-Format (High/Low DWORD).
' ============================================================
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
' ============================================================
' Type: WIN_FIND_DATA
' https://learn.microsoft.com/de-de/windows/win32/api/minwinbase/ns-minwinbase-win_find_dataw
' Enthält Dateiinformationen einer FindFirstFile/FindNextFile-Suche.
' ============================================================
Private Type WIN_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(0 To 259) As Integer
cAlternate(0 To 13) As Integer
End Type
' ============================================================
' Sentinel-Wert für ungültige Handles (keine Treffer gefunden)
' ============================================================
Private Const HANDLE_EMPTY As LongPtr = -1
' Datei-Attribut: Verzeichnis
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
' Eigene Struktur für Top-3-Dateien
Private Type tTopFile
FilePath As String
FileSize As Double
ft As FILETIME
End Type
Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Const MOVEFILE_REPLACE_EXISTING As Long = &H1
Private Const strEX As String = ".csv"
Private TopFiles(1 To 3) As tTopFile
Private blnRecursive As Boolean
Public Sub Main_3_CSV()
Dim strTarget As String
Dim strRoot As String
Dim lngCount As Long
Dim lngErr As Long
' Downloads-Ordner über API (robuster als Environ$)
strRoot = fncGetDLFolder()
' False = keine Unterordner
blnRecursive = False
' Top-3 nach Datum sammeln
InitTopFiles
SearchFolderRecursive strRoot
' =========================================================
' AB HIER: ZWEITER SCHRITT
' Sortierung der 3 neuesten Dateien nach Größe
' =========================================================
Call SortTop3BySize
' =========================================================
' Umbenennen:
' L1 = größte
' L2 = zweitgrößte
' L3 = kleinste
' =========================================================
For lngCount = 1 To 3
If Len(TopFiles(lngCount).FilePath) > 0 Then
strTarget = strRoot & "\L" & lngCount & strEX
If MoveFileEx(StrPtr(TopFiles(lngCount).FilePath), _
StrPtr(strTarget), _
MOVEFILE_REPLACE_EXISTING) = 0 Then
lngErr = GetLastError()
MsgBox "Fehler beim Umbenennen:" & vbCrLf & _
TopFiles(lngCount).FilePath & vbCrLf & "-> " & strTarget & vbCrLf & vbCrLf & _
GetWinError(lngErr), vbCritical
End If
End If
Next lngCount
End Sub
' ============================================================
' Setzt Top-3-Dateiliste zurück
' ============================================================
Private Sub InitTopFiles()
Erase TopFiles
End Sub
' ============================================================
' Sortiert die 3 bereits ermittelten neuesten Dateien
' nach Dateigröße (absteigend)
'
' Ergebnis:
' TopFiles(1) = größte Datei
' TopFiles(2) = zweitgrößte
' TopFiles(3) = kleinste
' ============================================================
Private Sub SortTop3BySize()
Dim i As Long, j As Long
Dim tmp As tTopFile
' Einfacher Bubble-Sort (bei nur 3 Elementen perfekt sinnvoll)
For i = 1 To 2
For j = i + 1 To 3
' Vergleich: Größe absteigend
If TopFiles(j).FileSize > TopFiles(i).FileSize Then
' Swap
tmp = TopFiles(i)
TopFiles(i) = TopFiles(j)
TopFiles(j) = tmp
End If
Next j
Next i
End Sub
' ============================================================
' Rekursive Dateisuche im Ordner
' Sammelt alle CSV-Dateien und bewertet sie nach Datum
' ============================================================
Private Sub SearchFolderRecursive(ByVal strFolder As String)
Dim wfd As WIN_FIND_DATA
Dim strSearch As String
Dim lngpFind As LongPtr
Dim strName As String
Dim strFull As String
strSearch = strFolder & "\*"
lngpFind = FindFirstFile(StrPtr(strSearch), wfd)
If lngpFind = HANDLE_EMPTY Then
Debug.Print "Keine Dateien gefunden."
Else
Do
strName = fncPtrToString(wfd.cFileName)
If strName <> "." And strName <> ".." Then
strFull = strFolder & "\" & strName
If (wfd.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> 0 Then
If blnRecursive Then SearchFolderRecursive strFull
Else
If LCase$(Right$(strName, 4)) = strEX Then
fncCheckTop3 strFull, wfd
End If
End If
End If
Loop While FindNextFile(lngpFind, wfd)
End If
FindClose lngpFind
End Sub
' ============================================================
' Ermittelt Downloads-Ordner via Known Folder API
' ============================================================
Private Function fncGetDLFolder() As String
Dim FOLDERID_Downloads As GUID
Dim lngpPath As LongPtr
Dim strPath As String
Dim lngLen As Long
' GUID für Downloads-Ordner
With FOLDERID_Downloads
.Data1 = &H374DE290
.Data2 = &H123F
.Data3 = &H4565
.Data4(0) = &H91
.Data4(1) = &H64
.Data4(2) = &H39
.Data4(3) = &HC4
.Data4(4) = &H92
.Data4(5) = &H5E
.Data4(6) = &H46
.Data4(7) = &H7B
End With
If SHGetKnownFolderPath(FOLDERID_Downloads, 0, 0, lngpPath) = 0 Then
lngLen = lstrlenW(lngpPath)
strPath = String$(lngLen, vbNullChar)
CopyMemory StrPtr(strPath), lngpPath, lngLen * 2
CoTaskMemFree lngpPath
fncGetDLFolder = strPath
End If
End Function
' ============================================================
' Prüft, ob Datei in Top-3 (neueste Dateien) gehört
' ============================================================
Private Sub fncCheckTop3(ByVal strFile As String, ByRef wfd As WIN_FIND_DATA)
If CompareFileTime(wfd.ftLastWriteTime, TopFiles(1).ft) Then
TopFiles(3) = TopFiles(2)
TopFiles(2) = TopFiles(1)
FillTopFile TopFiles(1), strFile, wfd
ElseIf CompareFileTime(wfd.ftLastWriteTime, TopFiles(2).ft) Then
TopFiles(3) = TopFiles(2)
FillTopFile TopFiles(2), strFile, wfd
ElseIf CompareFileTime(wfd.ftLastWriteTime, TopFiles(3).ft) Then
FillTopFile TopFiles(3), strFile, wfd
End If
End Sub
' ============================================================
' Füllt Struktur mit Dateiinformationen
' ============================================================
Private Sub FillTopFile(ByRef t As tTopFile, ByVal strFile As String, ByRef wfd As WIN_FIND_DATA)
t.FilePath = strFile
t.FileSize = CDbl(wfd.nFileSizeHigh) * 4294967296# + wfd.nFileSizeLow
t.ft = wfd.ftLastWriteTime
End Sub
' ============================================================
' Vergleicht zwei FILETIME-Strukturen (neu/alt)
' ============================================================
Private Function CompareFileTime(a As FILETIME, b As FILETIME) As Boolean
If a.dwHighDateTime > b.dwHighDateTime Then
CompareFileTime = True
ElseIf a.dwHighDateTime < b.dwHighDateTime Then
CompareFileTime = False
Else
CompareFileTime = (a.dwLowDateTime > b.dwLowDateTime)
End If
End Function
' ============================================================
' Wandelt Integer-Array (Unicode Pointer) in String um
' ============================================================
Private Function fncPtrToString(intArr() As Integer) As String
Dim strTemp As String
Dim lngCount As Long
For lngCount = LBound(intArr) To UBound(intArr)
If intArr(lngCount) = 0 Then Exit For
strTemp = strTemp & ChrW$(intArr(lngCount))
Next lngCount
fncPtrToString = strTemp
End Function
' ============================================================
' Wandelt Windows-Fehlercode in Textmeldung um
' ============================================================
Private Function GetWinError(ByVal lngErr As Long) As String
Dim strBuf As String
Dim lngRet As Long
strBuf = String$(512, vbNullChar)
lngRet = FormatMessage( _
FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, _
0, lngErr, 0, StrPtr(strBuf), 512, 0)
If lngRet > 0 Then
GetWinError = Left$(strBuf, lngRet)
Else
GetWinError = "Unbekannter Fehlercode: " & lngErr
End If
End Function
Zum "
spielen" für
dich -
Christian. ;-)
Hoffe ich habe alles richtig kopiert. ;-)
Servus
Case