1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123
|
unit base;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TFicheBase }
TFicheBase = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
public
var
LSimul: boolean;
function DelTree(const ARoot: string): boolean;
end;
var
FicheBase: TFicheBase;
implementation
{$R *.lfm}
procedure TFicheBase.FormCreate(Sender: TObject);
begin
LSimul := True;
end;
procedure TFicheBase.Button1Click(Sender: TObject);
begin
if DelTree(GetCurrentDir + '/dossier1') then ShowMessage('OK !')
else ShowMessage('Raté !')
end;
function TFicheBase.DelTree(const ARoot: string): boolean;
var
LRec: TSearchRec;
LRes: integer;
LRoot, LFileName: string;
label
__Exit;
begin
result := FALSE;
if LSimul then
WriteLn('REM Mode simulation');
LRoot := IncludeTrailingPathDelimiter(ARoot);
WriteLn('REM Exploration dossier: "', LRoot, '"');
if not DirectoryExists(LRoot) then
begin
WriteLn('ERR Dossier introuvable: "', LRoot, '"');
Exit;
end;
LRes := FindFirst(LRoot + '*', faAnyFile or faDirectory, LRec);
while LRes = 0 do
begin
if (LRec.Name = '') or (LRec.Name = '.') or (LRec.Name = '..') then
begin
WriteLn('REM Ignore: "', LRec.Name, '"');
LRes := FindNext(LRec);
Continue;
end;
{$IFDEF WINDOWS}
if (LRec.Attr and faReadOnly) = faReadOnly then
begin
WriteLn('REM Changement attribut: "', LFileName, '"');
if FileSetAttr(LFileName, LRec.Attr - faArchive) = CFileSetAttrErr then
begin
WriteLn('ERR Echec changement attribut: "', LFileName, '"');
goto __Exit;
end;
end;
{$ENDIF}
if (LRec.Attr and faDirectory) = faDirectory then
begin
if not Deltree(LRoot + LRec.Name) then
goto __Exit;
end else
begin
LFileName := LRoot + LRec.Name;
WriteLn('REM Suppression fichier: "', LFileName, '"');
if (not LSimul) and (not DeleteFile(LFileName)) then
begin
WriteLn('ERR Echec suppression fichier: "', LFileName, '"');
goto __Exit;
end;
end;
LRes := FindNext(LRec);
end;
WriteLn('REM Suppression dossier: "', LRoot, '"');
if (not LSimul) and (not RemoveDir(LRoot)) then
begin
WriteLn('ERR Echec suppression dossier: "', LFileName, '"');
goto __Exit;
end;
result := TRUE;
__Exit:
FindClose(LRec);
end;
end. |
Partager