|
| |
Fortgeschrittene Programmierung| An alle API-Profis | |  | | Autor: luet | | Datum: 03.09.02 19:44 |
| Hi,
Ich hab nachfolgende Function zum Schreddern von Dateien . Leider funzt das noch nicht so ganz .Krieg folgende Fehlermeldung :
Fehler 49 . Falsch Dll Aufrufkonvention .
Das ganze in der WriteFile-Zeile siehe *
Was mache ich falsch. Welcher Api-Profi kann mir helfen ?
Vielen Dank
Luet
Global NumberOfTimes As Long
Global Setting As String
Global Method As String Global Rename As Boolean
Global FileTemp As String
Const GENERIC_READ = &H80000000
Const GENERIC_WRITE = &H40000000.
Const FILE_SHARE_READ = &H1
Const FILE_SHARE_WRITE = &H2
Const CREATE_ALWAYS = 2
Const CREATE_NEW = 1
Const OPEN_ALWAYS = 4
Const OPEN_EXISTING = 3
Const TRUNCATE_EXISTING = 5
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_HIDDEN = &H2 .
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_FLAG_DELETE_ON_CLOSE = &H4000000 .
Const FILE_FLAG_NO_BUFFERING = &H20000000
Const FILE_FLAG_OVERLAPPED = &H40000000
Const FILE_FLAG_POSIX_SEMANTICS = &H1000000
Const FILE_FLAG_RANDOM_ACCESS = &H10000000
Const FILE_FLAG_SEQUENTIAL_SCAN = &H8000000
Const FILE_FLAG_WRITE_THROUGH = &H80000000
Declare Function WriteFile Lib "kernel32.dll" (ByVal hfile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Declare Function CreateFile Lib "kernel32.dll" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Declare Function SetFilePointer Lib "kernel32.dll" (ByVal hfile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Function Dateischredder(sPath As String)
Dim lVal, hfile, lNumWritten, i, j As Long
Dim dCount As Double
Dim dRest As Double
Dim sTemp As String
Dim lFileLength As Long
Dim sTemp0, sTemp1 As String
Dim RetVal As Variant
Dim iPasses As Integer
Const CWR_BUFFER = 32768 'write 32Kb blocks
sTemp0 = String(CWR_BUFFER, Chr$(0))
iPasses = 9
sTemp1 = String(CWR_BUFFER, Chr$(255))
lFileLength = FileLen(sPath)
dCount = Int((lFileLength) / CWR_BUFFER)
dRest = lFileLength - (dCount * CWR_BUFFER)
hfile = CreateFile(sPath, GENERIC_WRITE, 0, 0, OPEN_EXISTING, FILE_ATTRIBUTE_ARCHIVE Or FILE_FLAG_SEQUENTIAL_SCAN Or FILE_FLAG_DELETE_ON_CLOSE, 0)
If hfile = -1 Then
GoTo ErrSub
End If
For lVal = 1 To iPasses
If lFileLength > CWR_BUFFER Then
For i = 1 To dCount
*******************************
RetVal = WriteFile(hfile, ByVal sTemp0, ByVal CWR_BUFFER, ByVal
lNumWritten, ByVal 0&)
*******************************
Next i
End If
sTemp = String(dRest, Chr$(0))
RetVal = WriteFile(hfile, ByVal sTemp, Len(sTemp), lNumWritten, ByVal 0&)
sTemp = Empty
RetVal = SetFilePointer(hfile, 0, 0, 0)
dRest = lFileLength
If lFileLength > CWR_BUFFER Then
For i = 1 To dCount
RetVal = WriteFile(hfile, ByVal sTemp1, CWR_BUFFER, lNumWritten, 0)
Next i
End If
sTemp = String(dRest, Chr$(255))
RetVal = WriteFile(hfile, ByVal sTemp, Len(sTemp), lNumWritten, 0)
sTemp = Empty
RetVal = SetFilePointer(hfile, 0, 0, 0)
dRest = lFileLength
If lFileLength > CWR_BUFFER Then
For i = 1 To dCount
RetVal = WriteFile(hfile, ByVal sTemp1, CWR_BUFFER, lNumWritten, 0)
Next i
End If
sTemp = String(dRest, Chr$(0))
RetVal = WriteFile(hfile, ByVal sTemp, Len(sTemp), lNumWritten, 0)
sTemp = Empty
RetVal = SetFilePointer(hfile, 0, 0, 0) ' return to the begin of the file
Next lVal
Randomize
For j = 1 To iPasses
DoEvents
dRest = lFileLength
If lFileLength > CWR_BUFFER Then
For i = 1 To dCount
sTemp = String(CWR_BUFFER, Chr(Int(255 * Rnd) + 1))
RetVal = WriteFile(hfile, ByVal sTemp, CWR_BUFFER, lNumWritten, 0)
sTemp = Empty
Next i
End If
sTemp = String(dRest, Chr(Int(255 * Rnd) + 1))
RetVal = WriteFile(hfile, ByVal sTemp, Len(sTemp), lNumWritten, 0)
sTemp = Empty
RetVal = SetFilePointer(hfile, 0, 0, 0)
Next
If Rename = True Then
Dim RandomName, OldName, NewName As String
Dim a, b As Long
a = Rnd * 1000
b = Rnd * 1000
RandomName = a & "." & b 'the final random name
OldName = FileTemp
NewName = GetPath(FileTemp) & RandomName
Name OldName As NewName
End If
RetVal = CloseHandle(hfile)
ErrSub:
If Err.Number = 0 Then
If Err.Number = 9 Then
Resume Next
If Err.Number = 55 Then
Close #1
Else
MsgBox (Err.Number & vbCrLf & Err.Description), vbCritical + vbOKOnly, "Error"
End If: End If: End If
End Function | |
 | Sie sind nicht angemeldet!
Um auf diesen Beitrag zu antworten oder neue Beiträge schreiben zu können, müssen Sie sich zunächst anmelden.
 Einloggen | Neu registrieren |
 |
|
vb@rchiv CD Vol.6 vb@rchiv  Vol.6
Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
Online-Update-Funktion
Entwickler-Vollversionen
u.v.m.Jetzt zugreifen Tipp des Monats  Oktober 2025
Matthias KozlowskiUmlaute konvertierenErsetzt die Umlaute in einer Zeichenkette durch die entsprechenden Doppelbuchstaben (aus ä wird ae, usw.) sevZIP40 Pro DLL 
Zippen und Unzippen wie die Profis!
Mit nur wenigen Zeilen Code statten Sie Ihre Anwendungen ab sofort mit schnellen Zip- und Unzip-Funktionen aus. Hierbei lassen sich entweder einzelnen Dateien oder auch gesamte Ordner zippen bzw. entpacken. Weitere Infos
|
Sie sind aktuell nicht angemeldet.
