I have invented my own algorithm that I propose here, non-recursive, which takes up very little memory and removes folders of any depth and file (s) with special attributes. Unfortunately the comments are still in Italian.
To explain how it works: you have to initialize the deletion of the file or folder with the procedure InitDelT (Dir: String; Var DelTRec: TDelTRec); and run several times, for example in a sort of loop, the function DelT (Var DelTRec: TDelTRec): Byte;, which returns:
2 -> Deletion completed successfully.
3 -> Deletion failed.
The DelTRec variable: TDelTRec contains:
PathName, BaseDir, Msg: String;
Status: Byte;
{Status: 0 -> Deleting (no items deleted yet).
1 -> Deleting (1 item just deleted).
2 -> Deletion completed successfully.
3 -> Deletion failed}.
Unit DelTU;
Interface
Type TDelTRec=Record
PathName,BaseDir,Msg:String;
Status:Byte;
{Status: 0 -> Eliminazione in corso (nessun elemento ancora eliminato).
1 -> Eliminazione in corso (1 elemento appena eliminato).
2 -> Eliminazione terminata con successo.
3 -> Eliminazione fallita}
End;
Function KeepExtendedDir (Dir:String):String;
{Preleva la Dir non normalizzata
(con BACKSLASH) da Dir.
NOTE: Non effettua alcun accesso ad UNITà A DISCO}
Function KeepNormDir (Dir:String):String;
{Preleva la Dir normalizzata
(senza BACKSLASH) da Dir.
NOTE: Non effettua alcun accesso ad UNITà A DISCO}
Function GetPathNameDir (PathName:String):String;
{Ritorna l' UNITà ed il PERCORSO DI PathName}
Procedure FileSplit (FileName:String;
Var Drive,Dir,Name,Ext:String);
{Scompone un PERCORSO DI FILE FileName
IN UNITà (DRIVE), Dir (Dir), nome (Name)
ed estensione (Ext).
NOTE: Non effettua alcun accesso ad UNITà A DISCO}
Procedure FSplit (FileName:String;
Var Dir,Name,Ext:String);
{Scompone un PERCORSO DI FILE FileName
Path (Dir), nome (Name)
ed estensione (Ext).
NOTE: Non effettua alcun accesso ad UNITà A DISCO}
Function Is_Drive_Or_Root (Dir:String):Boolean;
{Verifica Se la Dir specificata da Dir è
una ROOT Dir o un DRIVE (IN questo caso ritorna TRUE).
Ritorna FALSE Se Dir è una Sub-DIRECTORY}
Function File_Exists_Sub (FileName:String;Attr:Integer;
Var Attr_Read:Integer):Boolean;
{Verifica che un FILE o una Dir FileName esista
ed abbia attributi compresi IN Attr.
Se FileName ha uno o più attributi che differiscono da Attr, ritorna FALSE.
Se FileName non ha attributi, ritorna TRUE.
Ritorna FALSE solo IN caso DI ERRORE,
altrimenti Attr_Read contiene gli attributi DI FileName.
NOTE: Per trovare qualsiasi FILE:
Attr= faAnyFile-
faVolumeId-
faDirectory.
Per trovare qualsiasi FILE E DIRECTORY:
Attr= faAnyFile-
faVolumeId.
Per trovare qualsiasi DIRECTORY:
Found:=File_Exists_Sub(FileName,faAnyFile-faVolumeId,Attr_Read) AND
((Attr_Read AND faDirectory)<>0)}
Function File_Exists (FileName:String):Boolean;
(* Controlla che FileName sia un FILE esistente *)
Function Dir_Exists (FileName:String):Boolean;
(* Controlla che FileName sia una DIRECTORY esistente *)
Function FDel (Source:String):Boolean;
(* Rimuove qualsiasi file, anche con attributi speciali;
non imposta ErrorMsg *)
Function RmDir (Source:String):Boolean;
(* Rimuove qualsiasi directory vuota, anche con attributi speciali;
non imposta ErrorMsg *)
Procedure InitDelT (Dir:String;
Var DelTRec:TDelTRec);
{Inizializzazione funzione "remove not empty folder" alias DelT().
Dir è il percorso assoluto della cartella da rimuovere;
può essere specificato anche senza il backslash finale.
Nel caso Dir non esista, questa funzione disabilita la rimozione;
altrimenti essa potrà avvenire in background, chiamando DelT()}
Function DelT (Var DelTRec:TDelTRec):Byte;
{Funzione "remove not empty folder" alias DelT().
La rimozione potrà avvenire in background, chiamando DelT() dopo
aver inizializzato DelTRec con InitDelT().
Ritorna: 0 -> Eliminazione in corso (nessun elemento ancora eliminato).
1 -> Eliminazione in corso (1 elemento appena eliminato).
2 -> Eliminazione terminata con successo.
3 -> Eliminazione fallita.
ALGORITMO:
---------:
- specificare full-path-name PathName con filtro *.*;
es.: c:\programs.pf\graphic.pf\*.*
- Copiare nella base-path BaseDir il percorso della cartella da rimuovere;
es.: c:\programs.pf
- RemoveDir <- False.
- Preleva FileName1 e Dir da PathName.
- Se FileName1="<Rm_Dir>":
- RemoveDir <- True.
- Preleva FileName1 e Dir da Dir (normalizzata).
- NoSuchFile1 <- False
- Cerca la prima ricorrenza di FileName1 in Dir.:
- Imposta NoSuchFile1 <- True, se non esiste.
- NoSuchFile2 <- True
- SetFileName2 <- False
- Se NoSuchFile1 = False:
- Cerca il file o dir. successivo FileName2 in Dir:
- Imposta NoSuchFile2 <- True, se non esiste.
- Se RemoveDir=True:
- Rimuove la dir. FileName1
- Se Dir=BaseDir, ha finito.
- SetFileName2 <- True
- Se RemoveDir=False:
- Se FileName1 è un file:
- Rimuove il file FileName1.
- SetFileName2 <- True
- Se FileName1 è una dir.:
- Imposta PathName con Dir., FileName1 e *.*
- Se (NoSuchFile2 = False) E SetFileName2:
- Se FileName2 è un file, imposta PathName con Dir. e FileName2
- Se FileName2 è una dir., imposta PathName con Dir., FileName2 e *.*
- Se (NoSuchFile2 = True) E SetFileName2 O
(NoSuchFile1 = True):
- Imposta PathName con Dir. e "<Rm_Dir>"}
{-----------------------------------------------------------------------}
Implementation
Uses SysUtils;
Function KeepExtendedDir(Dir:String):String;
Var Len:Integer;
Begin
Len:=Length(Dir);
If (Len>0) And Not (Dir[Len] In [':','\']) Then
KeepExtendedDir:=Dir+'\'
Else
KeepExtendedDir:=Dir;
End;
Function KeepNormDir(Dir:String):String;
Var Len:Integer;
Begin
Len:=Length(Dir);
If (Len>1) And
(Dir[Len]='\') And
(Dir[Len-1]<>':') Then
KeepNormDir:=Copy(Dir,1,Len-1)
Else
KeepNormDir:=Dir;
End;
Function GetPathNameDir(PathName:String):String;
Var Index:Integer;
Begin
Index:=Length(PathName);
While (Index>0) And Not (PathName[Index] In ['\',':']) Do
Dec(Index);
GetPathNameDir:=Copy(PathName,1,Index);
End;
Procedure FileSplit(FileName:String;
Var Drive,Dir,Name,Ext:String);
Var Ch:Char;
Index,Flag:Integer;
Begin
Drive:='';
Dir:='';
Name:='';
Ext:='';
Flag:=0;
Index:=Length(FileName);
While Index>0 Do
Begin
Ch:=FileName[Index];
Case Ch Of
'\':If Flag<3 Then
Flag:=2;
':':Flag:=3;
'.':If Flag=0 Then
Flag:=1;
End;
Case Flag Of
0:Name:=Ch+Name;
1:If Ext='' Then
Begin
Ext:=Ch+Name;
Name:='';
End
Else
Name:=Ch+Name;
2:Dir:=Ch+Dir;
3:Drive:=Ch+Drive;
End;
Dec(Index);
End;
End;
Procedure FSplit(FileName:String;
Var Dir,Name,Ext:String);
Var Drive:String;
Begin
FileSplit(FileName,Drive,Dir,Name,Ext);
Dir:=Drive+Dir;
End;
Function Is_Drive_Or_Root(Dir:String):Boolean;
Const Special_Chars:Array[Boolean] Of Char=(':','\');
Var Len:Integer;
Begin
Len:=Length(Dir);
Is_Drive_Or_Root:=((Len=1) Or (Len=2) Or (Len=3) And (Dir[2]=':')) And
(Dir[Len]=Special_Chars[Odd(Len)]);
End;
Function File_Exists_Sub(FileName:String;Attr:Integer;
Var Attr_Read:Integer):Boolean;
(* per trovare qualsiasi FILE:
Attr= faAnyFile-
faVolumeId-
faDirectory *)
Var TempOut:Boolean;
SR:TSearchRec;
Begin
Attr_Read:=0;
TempOut:=((Attr And faDirectory)<>0) And
Is_Drive_Or_Root(FileName);
If Not TempOut And
(FindFirst(FileName,Attr,SR)=0) Then
Begin
TempOut:=True;
Attr_Read:=SR.Attr;
FindClose(SR);
End;
File_Exists_Sub:=TempOut;
End;
Function File_Exists(FileName:String):Boolean;
Var Attr_Read:Integer;
Begin
File_Exists:=File_Exists_Sub(FileName,SysUtils.faAnyFile-
SysUtils.faVolumeId-
SysUtils.faDirectory,
Attr_Read);
End;
Function Dir_Exists(FileName:String):Boolean;
Var Attr_Read:Integer;
Begin
Dir_Exists:=File_Exists_Sub(FileName,SysUtils.faAnyFile-
SysUtils.faVolumeId,
Attr_Read) And
((Attr_Read And faDirectory)<>0);
End;
Function FDel(Source:String):Boolean;
Var Attr:Integer;
Begin
FDel:=False;
Source:=KeepNormDir(Source);
Attr:=SysUtils.FileGetAttr(Source);
If (Attr And SysUtils.faDirectory)=0 Then
Begin
If (Attr And (SysUtils.faReadOnly+
SysUtils.faHidden+
SysUtils.faSysFile))<>0 Then
SysUtils.FileSetAttr(Source,
Attr And Not (SysUtils.faReadOnly+
SysUtils.faHidden+
SysUtils.faSysFile));
FDel:=DeleteFile(Source);
End;
End;
Function RmDir(Source:String):Boolean;
Var Attr:Integer;
Begin
RmDir:=False;
Source:=KeepNormDir(Source);
Attr:=SysUtils.FileGetAttr(Source);
If (Attr And SysUtils.faDirectory)<>0 Then
Begin
If (Attr And (SysUtils.faReadOnly+
SysUtils.faHidden+
SysUtils.faSysFile))<>0 Then
SysUtils.FileSetAttr(Source,
Attr And Not (SysUtils.faReadOnly+
SysUtils.faHidden+
SysUtils.faSysFile));
RmDir:=RemoveDir(Source);
End;
End;
Procedure InitDelT(Dir:String;
Var DelTRec:TDelTRec);
Begin
With DelTRec Do
Begin
PathName:=KeepExtendedDir(Dir)+'*.*';
Dir:=KeepNormDir(Dir);
Status:=3 And -Byte(Not Dir_Exists(Dir));
BaseDir:=GetPathNameDir(Dir);
Msg:='';
End;
End;
Function DelT(Var DelTRec:TDelTRec):Byte;
Var RemoveDir,SuchFile1,SuchFile2,SetFileName2,FF:Boolean;
Dir,Name,Ext:String;
SR1,SR2:TSearchRec;
Begin
With DelTRec Do
Begin
If Status<2 Then
Begin
Status:=0;
RemoveDir:=False;
FSplit(PathName,Dir,Name,Ext);
If Name+Ext='<Rm_Dir>' Then
Begin
RemoveDir:=True;
FSplit(KeepNormDir(Dir),Dir,Name,Ext);
End;
FF:=FindFirst(Dir+'*.*',
SysUtils.faAnyFile-
SysUtils.faVolumeId,SR2)=0;
SuchFile1:=FF;
While SuchFile1 And
((SR2.Name='.') Or (SR2.Name='..')) Do
SuchFile1:=FindNext(SR2)=0;
SuchFile2:=False;
SetFileName2:=False;
If SuchFile1 Then
Begin
SR1:=SR2;
SuchFile2:=FindNext(SR2)=0;
If RemoveDir Then
Begin
Msg:=Dir+Name+Ext;
If Not RmDir(Msg) Then
Status:=3
Else
If Dir=BaseDir Then
Status:=2
Else
Status:=1;
SetFileName2:=True;
End
Else
If (SR1.Attr And SysUtils.faDirectory)=0 Then
Begin
Msg:=Dir+SR1.Name;
If FDel(Msg) Then
Status:=1
Else
Status:=3;
SetFileName2:=True;
End
Else
PathName:=Dir+SR1.Name+'\*.*';
End;
If SuchFile2 And SetFileName2 Then
If (SR2.Attr And SysUtils.faDirectory)=0 Then
PathName:=Dir+SR2.Name
Else
PathName:=Dir+SR2.Name+'\*.*';
If Not SuchFile2 And SetFileName2 Or Not SuchFile1 Then
PathName:=Dir+'<Rm_Dir>';
If FF Then
FindClose(SR2);
End;
DelT:=Status;
End;
End;
End.
This is an example (DelTUT.DPR):
program DelTUT;
{$APPTYPE CONSOLE}
uses SysUtils,
DelTU in 'DelTU.pas';
Var DelTRec:TDelTRec;
Dir:String;
begin
{ TODO -oUser -cConsole Main : Insert code here }
WriteLn('Insert the full path-name of the folder to remove it:');
ReadLn(Dir);
WriteLn('Press ENTER to proceed ...');
InitDelT(Dir,DelTRec);
WriteLn('Removing...');
While Not (DelT(DelTRec) In [2,3]) Do
Write(#13,DelTRec.Msg,#32);
WriteLn;
If DelTRec.Status=3 Then
WriteLn('Error!')
Else
WriteLn('Ok.')
end.
https://stackoverflow.com/questions/17812551
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
Russian