Shredder Folder Complete

In dem folgenden Beispiel wird der ganze Ordner samt allen Unterordnern und Dateien geschreddert, wenn  kein Prozess auf diesen Ordner zugreift.

Als Erstes wird der gesamte Ordner-Separator des Verzeichnisbaums entfernt, bevor alle Dateien überschrieben und gelöscht werden.

uses FileCtrl

const
  {$IFDEF LINUX}
  PathSeparator   = '/';
  {$ENDIF LINUX}
  {$IFDEF WIN32}
  DriveLetters    = ['a'..'z', 'A'..'Z'];
  PathDevicePrefix = '//./';
  PathSeparator   = '/';
  PathUncPrefix   = '//';
  {$ENDIF WIN32}

  type
  TDelTreeProgress = function (const FileName: string; Attr: DWORD): Boolean;

//

public
    { Public declarations }
    function DelTree(const Path: string): Boolean;
    function PathRemoveSeparator(const Path: string): string;
    function BuildFileList(const Path: string; const Attr: Integer; const List: TStrings): Boolean;
    function DelTreeEx(const Path: string; AbortOnFailure: Boolean; Progress: TDelTreeProgress): Boolean;
    
//

function TForm1.DelTree(const Path: string): Boolean;
begin
  Result := DelTreeEx(Path, False, nil);
end;

function TForm1.DelTreeEx(const Path: string; AbortOnFailure: Boolean; Progress: TDelTreeProgress): Boolean;
var
  Files: TStringList;
  LPath: string; // writable copy of Path
  FileName: string;
  I: Integer;
  PartialResult: Boolean;
  Attr: DWORD;
begin
  Result := True;
  Files := TStringList.Create;
  try
    LPath := PathRemoveSeparator(Path);
    BuildFileList(LPath + '/*.*', faAnyFile, Files);
    for I := 0 to Files.Count - 1 do
    begin
      FileName := LPath + '/' + Files[I];
      PartialResult := True;
      // If the current file is itself a directory then recursively delete it
      Attr := GetFileAttributes(PChar(FileName));
      if (Attr <> DWORD(-1)) and ((Attr and FILE_ATTRIBUTE_DIRECTORY) <> 0) then
        PartialResult := DelTreeEx(FileName, AbortOnFailure, Progress)
      else
      begin
        if Assigned(Progress) then
          PartialResult := Progress(FileName, Attr);
        if PartialResult then
        begin
          // Set attributes to normal in case it's a readonly file
          PartialResult := SetFileAttributes(PChar(FileName), FILE_ATTRIBUTE_NORMAL);
          if PartialResult then
            PartialResult := DeleteFile(FileName);
        end;
      end;
      if not PartialResult then
      begin
        Result := False;
        if AbortOnFailure then
          Break;
      end;
    end;
  finally
    FreeAndNil(Files);
  end;
  if Result then
  begin
    // Finally remove the directory itself
    Result := SetFileAttributes(PChar(LPath), FILE_ATTRIBUTE_NORMAL);
    if Result then
    begin
      {$I-}
      RmDir(LPath);
      {$I+}
      Result := IOResult = 0;
    end;
  end;
end;

function TForm1.PathRemoveSeparator(const Path: string): string;
var
  L: Integer;
begin
  L := Length(Path);
  if (L <> 0) and (AnsiLastChar(Path) = PathSeparator) then
    Result := Copy(Path, 1, L - 1)
  else
    Result := Path;
end;

function TForm1.BuildFileList(const Path: string; const Attr: Integer;
  const List: TStrings): Boolean;
var
  SearchRec: TSearchRec;
  R: Integer;
begin
  Assert(List <> nil);
  R := FindFirst(Path, Attr, SearchRec);
  Result := R = 0;
  if Result then
  begin
    while R = 0 do
    begin
      if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
        List.Add(SearchRec.Name);
      R := FindNext(SearchRec);
    end;
    Result := R = ERROR_NO_MORE_FILES;
    SysUtils.FindClose(SearchRec);
  end;
end;

Beispiel :

procedure TForm1.Button1Click(Sender: TObject);
begin
  if DirectoryExists('C:\temp')then
   begin
     DELTREE('C:\temp');
   end;
end;