我正试图编写两个函数来添加和删除IShellLibrary中的文件夹。我从这个开始，但函数在System._IntfClear:中产生了一个异常
第一次机会例外：168BC4年2月7日，$0000007。异常类$C000005，消息为"C0000005 ACCESS_VIOLATION"。
SHAddFolderPathToLibrary是导致异常的行。
我想我需要将库名称添加到函数中吗？
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;
这里的问题是翻译SHAddFolderPathToLibrary的Embarcadero工程师不了解COM引用计数，以及不同编译器如何处理它。
以下是如何在C++头文件Shobjidl.h中实现SHAddFolderPathToLibrary。它实际上是其他核心API调用的内联包装器：
__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;
}
德尔福的翻译非常忠实，确实太忠实了：
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;
问题出在对_Release的调用上。Delphi编译器管理引用计数，因此对_Release的显式调用是伪造的，不应该存在。由于编译器将安排对_Release的调用，因此这个额外的调用只会使引用计数不平衡。_AddRef和_Release之所以以_为前缀，是为了提醒人们不要调用它们，并让编译器这样做。
C++版本中对Release的调用是准确的，因为C++编译器不会自动为您调用Release，除非您将接口封装在COM智能指针中。但Embarcadero的工程师盲目地将其复制过来，后果自负。显然，Embarcadero的工程师从未执行过该代码。
您需要提供您自己对该函数的正确实现。以及任何其他错误翻译的函数。在ShlObj单元中搜索_Release，并在更正的版本中删除它们。翻译中还有其他错误，所以要小心。例如，SHLoadLibraryFromItem（和其他）声明局部变量plib: ^IShellLibrary，它应该是plib: IShellLibrary。
我提交了一份QC报告：QC#117351。
我发明了自己的算法，我在这里提出了非递归算法，它占用的内存非常少，可以删除任何深度的文件夹和具有特殊属性的文件。不幸的是，这些评论仍然是意大利语。为了解释它的工作原理：您必须使用过程InitDelT (Dir: String; Var DelTRec: TDelTRec); 初始化文件或文件夹的删除，并运行多次，例如在某种循环中，函数DelT (Var DelTRec: TDelTRec): Byte;，它返回：2 -> Deletion completed successfully.3 -> Deletion failed.DelTRec变量：TDelTRec包含：PathName, BaseDir, Msg: String;Status: Byte;{Status: 0 -> Deleting (no items deleted yet). 1 -> Deleting (1 item just deleted). 2 -> Deletion completed successfully.CCD_ 29。
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.pfgraphic.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.
这是一个例子（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.