Add, Remove Folder from IShellLibrary

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.