Borrado seguro de archivos

unit SecureDel;
 
interface 
 
function BorrarFichero(const NombreFichero: String): Boolean;
 
implementation 
 
uses 
   Windows, SysUtils;
 
const 
   TAMANIO_BUFFER = 65536;
   NRO_BUFFERS = 3;
 
var 
   FBuffers: array [0..NRO_BUFFERS-1] of ^byte;
 
procedure CrearBuffers;
var 
   i, j: Integer;
   p: ^byte;
begin 
  // obtenemos la memoria para los buffers (64Kb cada uno)
  // y los rellenamos con info aleatoria
   Randomize;
   for i:=0 to Pred( NRO_BUFFERS ) do begin 
       GetMem( FBuffers[i], TAMANIO_BUFFER );
       case i of 
            0: ;  // relleno con ceros (lo hace el sistema)
            1: FillChar( FBuffers[i]^, TAMANIO_BUFFER, $FF );
            2: begin 
                   p := @(FBuffers[i]^);
                   for j := TAMANIO_BUFFER downto 1 do begin 
                      p^ := byte( Random( $FF ) );
                      Inc(p);
                   end; 
               end; 
       end; 
   end; 
end; 
 
procedure DestruirBuffers;
var i: Integer;
begin 
  for i:=0 to Pred( NRO_BUFFERS ) do FreeMem( FBuffers[i] )
end; 
 
function RenombrarFichero(const NombreFichero: String; var NuevoNombreFichero: String): Boolean;
const 
   NRO_VECES_RENOMBRA = 26;
var 
   i, j : Integer;
   TmpNombreFichero, Ruta: String;
begin 
   Ruta := ExtractFilePath( NombreFichero );
   TmpNombreFichero := ExtractFileName( NombreFichero );
   NuevoNombreFichero := TmpNombreFichero;
   for i:= 0 to Pred( NRO_VECES_RENOMBRA ) do begin 
       for j := 1 to Length( NuevoNombreFichero ) do 
           if NuevoNombreFichero[j] <> '.'
              then NuevoNombreFichero[j] := Char( Ord('A') + i );
       if FileExists( Ruta + NuevoNombreFichero )
          then Continue;
       Result := RenameFile( Ruta + TmpNombreFichero, Ruta + NuevoNombreFichero );
       if not Result
          then Exit;
       TmpNombreFichero := NuevoNombreFichero;
   end; 
   NuevoNombreFichero := Ruta + NuevoNombreFichero;
end; 
 
procedure MachacarFichero(const h: THandle; Longitud: Cardinal);
var 
  i: Integer;
  Posicion, TotalBytes, BytesEscritos, BytesAEscribir: Cardinal;
begin 
  Posicion := Longitud;
  for i:=0 to NRO_BUFFERS-1 do begin 
     if i <> 0
        then SetFilePointer( h, -Posicion, nil, FILE_CURRENT );
     TotalBytes := 0;
     while TotalBytes < Longitud do begin 
         if Longitud - TotalBytes > TAMANIO_BUFFER
                 then BytesAEscribir := TAMANIO_BUFFER
                 else BytesAEscribir := Longitud - TotalBytes;
         BytesEscritos := FileWrite( h, (FBuffers[i])^, BytesAEscribir );
         if BytesEscritos = $FFFFFFFF
            then RaiseLastWin32Error;
         Inc( TotalBytes, BytesEscritos );
     end; 
  end; 
end; 
 
function BorrarFichero(const NombreFichero: String): Boolean;
var 
  h: THandle;
  UltNomFich: String;
  TamanioFileHi, TamanioFileLo, BytesAEscribir: Cardinal;
  TamanioFile, BytesEscritos: Int64;
begin 
 
  Result := False;
 
  // cambiamos atributos del archivo por si tuviera atributos de solo lectura
  Result := FileSetAttr( NombreFichero, faArchive ) = 0;
  if not Result then begin 
     RaiseLastWin32Error;
     Exit;
  end; 
 
  // abrimos el archivo para escritura
  h := FileOpen( NombreFichero, fmOpenWrite );
  Result := h <> -1;
  if not Result then begin 
     RaiseLastWin32Error;
     Exit;
  end; 
 
  // creamos los buffers de escritura de archivo
  CrearBuffers;
 
  try
     // obtenemos tamaño del archivo
     TamanioFileLo := GetFileSize( h, @TamanioFileHi );
 
     // si el archivo no tiene tamaño 0, lo machacamos
     if ( TamanioFileLo > 0 ) or ( TamanioFileHi > 0 ) then begin 
 
         // ponemos el puntero del archivo al final
         Dec( TamanioFileLo );
         if ( TamanioFileLo = $FFFFFFFF ) and ( TamanioFileHi > 0 )
            then Dec( TamanioFileHi );
         SetFilePointer( h, TamanioFileLo, @TamanioFileHi, FILE_BEGIN );
 
         // escribimos un cero byte al final del archivo, lo q hace
         // q el SO rellene con ceros todo el espacio ocupado por el archivo
         MachacarFichero(h, 1);
 
         // volvemos al principio del archivo y sobreescribimos
         SetFilePointer( h, 0, nil, FILE_BEGIN );
         BytesEscritos := 0;
         TamanioFile := TamanioFileLo or (TamanioFileHi shl 32);
         while BytesEscritos < TamanioFile do 
         begin 
             if TamanioFile - BytesEscritos < TAMANIO_BUFFER
                then BytesAEscribir := TamanioFile - BytesEscritos
                else BytesAEscribir := TAMANIO_BUFFER;
             MachacarFichero( h, BytesAEscribir );
             Inc( BytesEscritos, BytesAEscribir );
         end; 
     end; 
  finally
     // cerramos el archivo y liberamos memoria
     FileClose( h );
     DestruirBuffers;
  end; 
 
  // cambiamos el archivo de nombre repetidas veces
  Result := RenombrarFichero( NombreFichero, UltNomFich );
 
  // finalmente, borramos el archivo
  if Result then Result := DeleteFile( UltNomFich );
 
end; 
 
end.

uses 
  SecureDel;
 
....
 
procedure TForm1.Button1Click(Sender: TObject);
begin 
   if edFile.Text <> '' then 
      if FileExists(edFile.Text) then 
         if BorrarFichero(edFile.Text) then 
         begin 
            ShowMessage('¡Hecho!');
            edFile.Clear;
         end 
      else 
        showmessage('El archivo no existe');
end;