unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,
ComObj, ShlObj,
ActiveX;
type
TForm1 =
class(TForm)
Button1: TButton;
procedure WndProc(
var Message: TMessage);
override;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
aContextMenu: IContextMenu;
aContextMenu2: IContextMenu2;
implementation
{$R *.dfm}
procedure TForm1.WndProc(
var Message: TMessage);
begin
case Message.Msg
of
WM_INITMENUPOPUP,
WM_DRAWITEM,
WM_MENUCHAR,
WM_MEASUREITEM:
if Assigned(aContextMenu2)
then
begin
If (aContextMenu2.HandleMenuMsg(
Message.Msg,
Message.wParam,
Message.lParam) <> NOERROR)
then
inherited WndProc(
Message)
else
Message.Result := 0;
end
else
inherited WndProc(
Message);
else
inherited WndProc(
Message);
end;
end;
function SlashDirName(ADir:
String):
String;
var
s:
String;
bRootDir: Boolean;
begin
if ADir<>'
'
then
begin
s := ADir;
bRootDir := ((Length(s)=3)
and (s[2]='
:'))
or (s='
\');
if not bRootDir
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
begin
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
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
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)));
// Ab hier wird das Kontextmenü zusammengebaut und angezeigt
// Stattdessen:
// 1. Menüpunkte iterieren und gewünschten Eintrag erkennen (Text? ID?)
// 2. Dessen Aktion ausführen
aPopup := CreatePopUpMenu;
if aPopup=0
then
Exit;
try
OLECheck(aContextMenu.QueryContextMenu(aPopup, 0, 1, $7FFF, CMF_EXPLORE
or CMF_CANRENAME));
OLECheck(aContextMenu.QueryInterface(IID_IContextMenu2, aContextMenu2));
//To handle submenus.
try
aCmd := Integer(TrackPopupMenu(aPopup, TPM_LEFTALIGN
or TPM_LEFTBUTTON
or TPM_RIGHTBUTTON
or TPM_RETURNCMD, X, Y, 0,
Handle,
nil));
if aCmd<>0
then
begin
FillChar(aCmdInfo, Sizeof(aCmdInfo), 0);
with aCmdInfo
do
begin
cbSize := SizeOf(TCMInvokeCommandInfo);
lpVerb := PAnsiChar(MakeIntResource(aCmd-1));
nShow := SW_SHOWNORMAL;
end;
try
aContextMenu.InvokeCommand(aCmdInfo);
except
end;
end;
finally
aContextMenu2 :=
nil;
end;
finally
DestroyMenu(aPopup);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ContextMenuForFile('
C:\', 100, 100, Application.Handle);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
aContextMenu2 :=
nil;
end;
end.