Dateischredder Eine Funktion, die das sichere Löschen von Dateien bietet - ohne jegliche Rekonstruier-Möglichkeit!
Autor:   Christian Lütgens	Bewertung:     [ Jetzt bewerten ]	Views:  17.104
www.dateicommander.de	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 25 Bewertung insgesamt: nützlich Durchschnittliche Bewertung: 3.5 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

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