uses ShellApi, ShlObj, ComObj, FileCtrl,
ActiveX;
{$R *.DFM}
var
mContextMenu: IContextMenu;
mContextMenu2: IContextMenu2;
function SHGetIDListFromPath(FileName: TFileName;
var ShellFolder: IShellFolder): PItemIDList;
var
sParseName:
String;
mTempPath, mNextDir: TFileName;
iScanParam: Integer;
iDidGet: Cardinal;
mFolder, mSubFolder: IShellFolder;
mPIDL, mPIDLbase: PItemIDList;
mParseStruct: TStrRet;
mEList: IEnumIDList;
procedure GetDirs(
var TempPath, NextDir: TFileName);
var
iSlashPos: Integer;
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;
begin
iSlashPos := Pos('
\', TempPath);
if iSlashPos > 0
then
begin
if Pos('
:', TempPath) > 0
then
NextDir := Copy(TempPath, 1, 3)
else
NextDir := SlashDirName(NextDir) + Copy(TempPath, 1, iSlashPos - 1);
TempPath := Copy(TempPath, iSlashPos + 1, Length(TempPath));
end
else
begin
if NextDir = '
'
then
NextDir := TempPath
else
NextDir := SlashDirName(NextDir) + TempPath;
TempPath := '
';
end;
end;
begin
SHGetDesktopFolder(mFolder);
SHGetSpecialFolderLocation(0, CSIDL_DRIVES, mPIDLbase);
OLECheck(mFolder.BindToObject(mPIDLbase,
nil, IID_IShellFolder, Pointer(mSubFolder)));
mTempPath := FileName;
mNextDir := '
';
while Length(mTempPath) > 0
do
begin
GetDirs(mTempPath,mNextDir);
mPIDL := mPidlBase;
iScanParam := SHCONTF_FOLDERS
or SHCONTF_INCLUDEHIDDEN;
if (mNextDir = FileName)
and (
not DirectoryExists(FileName))
then
iScanParam := iScanParam
or SHCONTF_NONFOLDERS;
if S_OK = mSubFolder.EnumObjects(0, iScanParam, mEList)
then
while S_OK = mEList.Next(1, mPIDL, iDidGet)
do
begin
OLECheck(mSubFolder.GetDisplayNameOf(mPIDL, SHGDN_FORPARSING, mParseStruct));
case mParseStruct.uType
of
STRRET_CSTR: sParseName := mParseStruct.cStr;
STRRET_WSTR: sParseName := WideCharToString(mParseStruct.pOleStr);
STRRET_OFFSET: sParseName := PChar(DWORD(mPIDL) + mParseStruct.uOffset);
end;
if UpperCase(sParseName) = UpperCase(mNextDir)
then
Break;
end
else
begin
mFolder :=
nil;
Result :=
nil;
Exit;
end;
if iDidGet = 0
then
begin
mFolder :=
nil;
Result :=
nil;
Exit;
end;
mPIDLBase := mPIDL;
mFolder := mSubFolder;
if not FileExists(mNextDir)
then
OLECheck(mFolder.BindToObject(mPIDL,
nil, IID_IShellFolder, Pointer(mSubFolder)));
end;
ShellFolder := mFolder;
if ShellFolder =
nil then
Result :=
nil
else
Result := mPIDL;
end;
procedure ContextMenuForFile(FileName: TFileName; X, Y: Integer;
Handle: HWND);
var
mPopup: HMENU;
mCmd: Integer;
mCmdInfo: TCMInvokeCommandInfo;
mPIDL: PItemIDList;
mShellFolder: IShellFolder;
S:
String;
begin
mPIDL := SHGetIDListFromPath(FileName, mShellFolder);
if not Assigned(mPIDL)
then
Exit;
OLECheck(mShellFolder.GetUIObjectOf(
Handle, 1, mPIDL, IID_IContextMenu,
nil,
Pointer(mContextMenu)));
mPopup := CreatePopUpMenu;
if mPopup = 0
then
Exit;
try
OLECheck(mContextMenu.QueryContextMenu(Form1.PopupMenu1.Handle
{mPopup}, 0
{Index}, 1
{idCmdFirst}, 0
{_$7FFF}{idCmdLast}, CMF_NORMAL));
OLECheck(mContextMenu.QueryInterface(IID_IContextMenu2, mContextMenu2));
try
mCmd := Integer(TrackPopupMenuEx(Form1.PopupMenu1.Handle
{mPopup}, TPM_LEFTALIGN
or
TPM_RIGHTBUTTON
or TPM_HORIZONTAL
or TPM_VERTICAL
or TPM_RETURNCMD, X, Y,
Handle,
nil));
// Hint anzeigen
SetLength(S,40);
mContextMenu.GetCommandString(mCmd,GCS_HELPTEXT,
nil,PChar(S),SizeOf(S));
Form1.StatusBar1.Panels[0].Text := S;
// "OnClick" Ereignisse ausführen
if mCmd <> 0
then
case mCmd
of
1: Form1.A1.Click;
2: Form1.B1.Click;
else
begin
FillChar(mCmdInfo, SizeOf(mCmdInfo), 0);
with mCmdInfo
do
begin
cbSize := SizeOf(TCMInvokeCommandInfo);
lpVerb := MakeIntResource(mCmd - 1);
nShow := SW_SHOWNORMAL;
end;
try
mContextMenu.InvokeCommand(mCmdInfo);
except
// nichts tun
end;
end;
end;
finally
mContextMenu2 :=
nil;
end;
finally
DestroyMenu(mPopup);
end;
end;
procedure TForm1.WndProc(
var Message: TMessage);
begin
case Message.Msg
of
WM_INITMENUPOPUP,
WM_DRAWITEM,
WM_MENUCHAR,
WM_MEASUREITEM:
begin
if Assigned(mContextMenu2)
then
begin
If (mContextMenu2.HandleMenuMsg(
Message.Msg,
Message.wParam,
Message.lParam) <> NOERROR)
then
inherited WndProc(
Message)
else
Message.Result := 0;
end
else
inherited WndProc(
Message);
end;
else
inherited WndProc(
Message);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
mContextMenu2 :=
nil;
end;
// Aufruf
procedure TForm1.Button1Click(Sender: TObject);
begin
ContextMenuForFile('
C:\Eigene Dateien\_Test\Test.txt',Mouse.CursorPos.x,Mouse.CursorPos.y,
Handle);
end;