function SlashDirName(ADir:
String):
String;
var
S:
String;
RootDir: Boolean;
begin
if ADir<>'
'
then
begin
S:=ADir;
RootDir:=((Length(S)=3)
and (S[2]='
:'))
or (S='
\');
if not RootDir
then
if S[Length(S)]<>'
\'
then S:=S+'
\';
Result:=S;
end;
end;
function SHGetIDListFromPath(Path: TFileName;
var ShellFolder: IShellFolder): PItemIDList;
var
TempPath, NextDir: TFileName;
SlashPos: Integer;
Folder, subFolder: IShellFolder;
PIDL, PIDLbase: PItemIDList;
ParseStruct: TStrRet;
ParseNAme:
String;
EList: IEnumIDList;
DidGet: Cardinal;
ScanParam: Integer;
begin
SHGetDesktopFolder(Folder);
SHGetSpecialFolderLocation(0, CSIDL_DRIVES, PIDLbase);
OLECheck(Folder.BindToObject(PIDLbase,
nil, IID_IShellFolder, Pointer(SubFolder)));
TempPath:=Path;
NextDir:='
';
while Length(TempPath)>0
do
begin
SlashPos:=Pos('
\', TempPath);
if SlashPos > 0
then
begin
if Pos('
:', TempPath) > 0
then NextDir:=Copy(TempPath, 1, 3)
else NextDir:=SlashDirName(NextDir)+Copy(TempPath, 1, SlashPos-1);
TempPath:=Copy(TempPath, SlashPos+1, Length(TempPath));
end
else
begin
if NextDir='
'
then NextDir:=TempPath
else NextDir:=SlashDirName(NextDir)+TempPath;
TempPath:='
';
end;
PIDL:=PidlBase;
ScanParam:=SHCONTF_FOLDERS
or SHCONTF_INCLUDEHIDDEN;
if (NextDir=Path)
and (
not DirectoryExists(Path))
then
ScanParam:=ScanParam
or SHCONTF_NONFOLDERS;
if S_OK=SubFolder.EnumObjects(0, ScanParam, EList)
then
while S_OK=EList.Next(1, pidl, DidGet)
do
begin
OLECheck(SubFolder.GetDisplayNameOf(PIDL, SHGDN_FORPARSING, ParseStruct));
case ParseStruct.uType
of
STRRET_CSTR: ParseName:=ParseStruct.cStr;
STRRET_WSTR: ParseName:=WideCharToString(ParseStruct.pOleStr);
STRRET_OFFSET: Parsename:=PChar(DWORD(Pidl)+ParseStruct.uOffset);
end;
if UpperCase(Parsename)=UpperCase(NextDir)
then Break;
end
else
begin
Folder:=nil;
Result:=nil;
Exit;
end;
if DidGet=0
then
begin
Folder:=nil;
Result:=nil;
Exit;
end;
PIDLBase:=PIDL;
Folder:=subFolder;
if not FileExists(NextDir)
then
OLECheck(Folder.BindToObject(Pidl,
nil, IID_IShellFolder, Pointer(SubFolder)));
end;
ShellFolder:=Folder;
if ShellFolder=nil
then Result:=nil
else Result:=PIDL;
end;
procedure ContextMenuForFile(FileName: TFileName; X, Y: Integer;
Handle: HWND);
var
aContextMenu: IContextMenu;
aPrgOut: Pointer;
aPopup: HMENU;
aCmd: Integer;
aCmdInfo: TCMInvokeCommandInfo;
PIDL: PItemIDList;
ShellFolder: IShellFolder;
begin
PIDL:=SHGetIDListFromPath(FileName, ShellFolder);
if not Assigned(PIDL)
then Exit;
aPrgOut:=nil;
OLECheck(ShellFolder.GetUIObjectOf(0, 1, PIDL, IID_IContextMenu, aPrgOut, Pointer(aContextMenu)));
aPopup:=CreatePopUpMenu;
if aPopup=0
then Exit;
try
OLECheck(aContextMenu.QueryContextMenu(aPopup, 0, 1, $7FFF, CMF_NORMAL));
aCmd:=Integer(TrackPopupMenuEx(aPopup, TPM_LEFTALIGN
or TPM_RETURNCMD
or TPM_RIGHTBUTTON
or TPM_HORIZONTAL
or TPM_VERTICAL, X, Y,
Handle,
nil));
if aCmd<>0
then
begin
FillChar(aCmdInfo, Sizeof(aCmdInfo), 0);
with aCmdInfo
do
begin
cbSize:=SizeOf(TCMInvokeCommandInfo);
lpVerb:=MakeIntResource(aCmd-1);
nShow:=SW_SHOWNORMAL;
end;
try
aContextMenu.InvokeCommand(aCmdInfo);
except
end;
end;
finally
DestroyMenu(aPopup);
end;
end;