Wenn man seine gebrauchte Festplatte verkauft, will man sicher gehen, dass niemand an seine alten Daten kommt! Dieser Tipp zeigt ein Beispiel, wie man seine Dateien schnell und sicher schreddert!! Option Explicit ' Benötigte APIs und Konstanten Private Declare Function WriteFile Lib "kernel32" ( _ ByVal hfile As Long, _ lpBuffer As Any, _ ByVal nNumberOfBytesToWrite As Long, _ lpNumberOfBytesWritten As Long, _ lpOverlapped As Any) As Long Private 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 Private Declare Function CloseHandle Lib "kernel32.dll" ( _ ByVal hObject As Long) As Long Private Declare Function SetFilePointer Lib "kernel32.dll" ( _ ByVal hfile As Long, _ ByVal lDistanceToMove As Long, _ lpDistanceToMoveHigh As Long, _ ByVal dwMoveMethod As Long) As Long 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 ' Datei sicher "vernichten" Public Function Dateischredder(sPath As String, _ iAnzahl As Integer) 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 As String Dim sTemp1 As String Dim RetVal As Variant Dim Ant Dim AttrOld As Long Const Buffer = 32768 sTemp0 = String(Buffer, Chr$(0)) sTemp1 = String(Buffer, Chr$(255)) lFileLength = FileLen(sPath) If lFileLength < Buffer Then dRest = lFileLength Else dCount = Int((lFileLength) / Buffer) dRest = lFileLength - (dCount * Buffer) End If ' Prüfen, ob Datei schreibgeschützt ist AttrOld = GetAttr(sPath) If AttrOld = 1 Or AttrOld = 3 Or AttrOld = 5 Or _ AttrOld = 7 Or AttrOld = 33 Or AttrOld = 35 Or _ AttrOld = 35 Or AttrOld = 37 Or AttrOld = 39 Then Ant = MsgBox("Die Datei : " + sPath + vbCrLf + _ "ist schreibgeschütz, soll sie trotzdem geschreddert werden ?", _ vbExclamation + vbYesNo, "Schreibschutz aufheben ?") If Ant = vbNo Then Exit Function Else SetAttr sPath, vbArchive End If End If ' Datei öffnen 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 ' Datei kann nicht geöffnet werden GoTo ErrSub End If For lVal = 1 To iAnzahl ' 8 gilt offiziell als sicher If lFileLength > Buffer Then For i = 1 To dCount RetVal = WriteFile(hfile, ByVal sTemp0, _ ByVal Buffer, lNumWritten, ByVal 0&) DoEvents Next i End If sTemp = String(dRest, Chr$(90)) RetVal = WriteFile(hfile, ByVal sTemp, _ ByVal Len(sTemp), lNumWritten, ByVal 0&) sTemp = Empty ' zurück an den Anfang der Datei RetVal = SetFilePointer(hfile, 0, 0, 0) If lFileLength > Buffer Then For i = 1 To dCount RetVal = WriteFile(hfile, ByVal sTemp1, _ ByVal Buffer, lNumWritten, ByVal 0&) Next i End If sTemp = String(dRest, Chr$(255)) RetVal = WriteFile(hfile, ByVal sTemp, _ ByVal Len(sTemp), lNumWritten, ByVal 0&) sTemp = Empty ' zurück an den Anfang der Datei RetVal = SetFilePointer(hfile, 0, 0, 0) If lFileLength > Buffer Then For i = 1 To dCount RetVal = WriteFile(hfile, ByVal sTemp1, _ ByVal Buffer, lNumWritten, ByVal 0&) Next i End If sTemp = String(dRest, Chr$(140)) RetVal = WriteFile(hfile, ByVal sTemp, _ ByVal Len(sTemp), lNumWritten, ByVal 0&) sTemp = Empty ' zurück an den Anfang der Datei RetVal = SetFilePointer(hfile, 0, 0, 0) Next lVal ' noch ein paar Zufallszahlen dann läßt die Datei ' nicht mehr rekonstruieren Randomize For j = 1 To iAnzahl DoEvents If lFileLength > Buffer Then For i = 1 To dCount sTemp = String(Buffer, Chr(Int(255 * Rnd) + 1)) RetVal = WriteFile(hfile, ByVal sTemp, _ ByVal Buffer, lNumWritten, ByVal 0&) sTemp = Empty Next i End If sTemp = String(dRest, Chr(Int(255 * Rnd) + 1)) RetVal = WriteFile(hfile, ByVal sTemp, _ ByVal Len(sTemp), lNumWritten, ByVal 0&) sTemp = Empty ' zurück an den Anfang der Datei RetVal = SetFilePointer(hfile, 0, 0, 0) Next ' schließen und anschl. Datei löschen RetVal = CloseHandle(hfile) ErrSub: If Err.Number > 0 Then MsgBox (Err.Number & vbCrLf & Err.Description), vbCritical + vbOKOnly, "Error" End If End Function Beispiel für den Aufruf: ' Aufruf aus irgendeiner Prozedur Dim msg As String msg = "WARNUNG: " & _ "Dateien können nach dem Löschen nicht mehr " & _ "rekonstruiert werden!" & vbCrLf & vbCrLf & _ "Sind Sie ganz sicher?" If MsgBox(msg, vbExclamation + vbYesNo, _ "Dateien schreddern und löschen ?") = vbYes Then Dateischredder "d:\temp\Test1.txt", 9 End If Dieser Tipp wurde bereits 17.105 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
vb@rchiv CD Vol.6 Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! Online-Update-Funktion Entwickler-Vollversionen u.v.m. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 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. |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |