Add, Remove Folder from IShellLibrary - delphi

Question

I am attempting to write two functions that add and remove a folder from a IShellLibrary. I started with this, but the function produces an exception in System._IntfClear:
First chance exception at $000007FEFE 168BC4. Exception class $C0000005 with Message 'c0000005 ACCESS_VIOLATION'.
The SHAddFolderPathToLibrary is the line that causes the exception.
I guess I need to add the library name to the function?
function AddFolderToLibrary(AFolder: string): HRESULT;
{ Add AFolder to Windows 7 library. }
var
plib: IShellLibrary;
begin
Result := CoCreateInstance(CLSID_ShellLibrary, nil, CLSCTX_INPROC_SERVER,
IID_IShellLibrary, plib);
if SUCCEEDED(Result) then
begin
Result := SHAddFolderPathToLibrary(plib, PWideChar(AFolder));
end;
end;
function RemoveFolderFromLibrary(AFolder: string): HRESULT;
{ Remove AFolder from Windows 7 library. }
var
plib: IShellLibrary;
begin
Result := CoCreateInstance(CLSID_ShellLibrary, nil, CLSCTX_INPROC_SERVER,
IID_IShellLibrary, plib);
if SUCCEEDED(Result) then
begin
Result := SHRemoveFolderPathFromLibrary(plib, PWideChar(AFolder));
end;
end;

Answer 1

The problem here is that the Embarcadero engineer who translated SHAddFolderPathToLibrary does not understand COM reference counting, and how it is handled by different compilers.
Here's how SHAddFolderPathToLibrary is implemented in the C++ header file Shobjidl.h. It's actually an inline wrapper of other core API calls:
__inline HRESULT SHAddFolderPathToLibrary(_In_ IShellLibrary *plib,
_In_ PCWSTR pszFolderPath)
{
IShellItem *psiFolder;
HRESULT hr = SHCreateItemFromParsingName(pszFolderPath, NULL,
IID_PPV_ARGS(&psiFolder));
if (SUCCEEDED(hr))
{
hr = plib->AddFolder(psiFolder);
psiFolder->Release();
}
return hr;
}
And the Delphi translation is very faithful, indeed too faithful:
function SHAddFolderPathToLibrary(const plib: IShellLibrary;
pszFolderPath: LPCWSTR): HResult;
var
psiFolder: IShellItem;
begin
Result := SHCreateItemFromParsingName(pszFolderPath, nil, IID_IShellItem,
psiFolder);
if Succeeded(Result) then
begin
Result := plib.AddFolder(psiFolder);
psiFolder._Release();
end;
end;
The problem is the call to _Release. The Delphi compiler manages reference counting, and so this explicit call to _Release is bogus and should not be there. Since the compiler will arrange for a call to _Release, this extra one simply unbalances the reference counting. The reason why _AddRef and _Release are prefixed with _ is to remind people not to call them and to let the compiler do that.
The call to Release in the C++ version is accurate because C++ compilers don't automatically call Release for you unless you wrap the interface in a COM smart pointer. But the Embarcadero engineer has blindly copied it across and you are left with the consequences. Clearly this code has never even been executed by the Embarcadero engineers.
You'll need to supply your own corrected implementation of this function. And also any other erroneously translated function. Search for _Release in the ShlObj unit, and remove them in your corrected versions. There are other bugs in the translation, so watch out. For example, SHLoadLibraryFromItem (and others) declare local variable plib: ^IShellLibrary which should be plib: IShellLibrary.
I submitted a QC report: QC#117351.

Answer 2

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.