…
type
TShellMenuKind = (smkOnlyHandler, smkComplete, smkDefaultOnly, smkNoDefault);
type
TForm1 =
class(TForm)
…
public
{ Public-Deklarationen }
procedure WndProc(
var Message: TMessage);
override;
…
implementation
uses
ShellApi, ShlObj, ComObj, FileCtrl,
ActiveX, CommCtrl;
{$R *.DFM}
var
mContextMenu: IContextMenu;
mContextMenu2: IContextMenu2;
iHandlerIndex, iHandlerCount: Integer;
CanDraw, ValidCmdArea: Boolean;
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; HandlerIndex, X, Y: Integer;
Handle: HWND; PopupMenu: TPopupMenu; MenuType: TShellMenuKind);
var
mPopup: HMENU;
iCmd, iID, iRes, iCmdLast: Integer;
iFlags: Cardinal;
mCmdInfo: TCMInvokeCommandInfo;
mPIDL: PItemIDList;
mShellFolder: IShellFolder;
aMenuBitmaps:
array of TBitmap;
function ExecMenuItemAction(Cmd: Integer;
var ID: Integer; Item: TMenuItem): Boolean;
var
ix: Integer;
begin
Result := false;
ix := 0;
while ix < Item.Count
do
begin
Application.ProcessMessages;
if Cmd = ID
then
begin
Item[ix].Click;
Result := true;
Exit;
end;
if Item.Items[ix].Count > 0
then
ExecMenuItemAction(Cmd,ID,Item.Items[ix]);
Inc(ID);
Inc(ix);
end;
end;
function AddVCLMenuItems(APIMenu: HMENU;
var ID: Integer;
Item: TMenuItem; CanAddLine: Boolean; ArrayPos: Integer): Integer;
var
ix: Integer;
SubMenu: HMenu;
mBitmap: TBitmap;
function GetItemFlags(Item: TMenuItem): Cardinal;
begin
Result := MF_STRING;
if Item.Checked
then
Result := Result
or MF_CHECKED;
if not Item.Enabled
then
Result := Result
or MF_GRAYED;
if Item.Caption = cLineCaption
then
Result := Result
or MF_SEPARATOR;
end;
procedure AddMenuBitmap(MnuID: Integer; MnuItm: TMenuItem);
begin
SetLength(aMenuBitmaps,ArrayPos + 1);
aMenuBitmaps[ArrayPos] := TBitmap.Create;
aMenuBitmaps[ArrayPos].Width := 14;
aMenuBitmaps[ArrayPos].Height := 14;
if (Assigned(MnuItm.Bitmap))
and (
not MnuItm.Bitmap.Empty)
then
begin
aMenuBitmaps[ArrayPos].Canvas.StretchDraw(Rect(0,0,16,16),MnuItm.Bitmap);
aMenuBitmaps[ArrayPos].TransparentColor := MnuItm.Bitmap.Canvas.Pixels[0,0];
aMenuBitmaps[ArrayPos].Transparent := true;
end
else
if (MnuItm.ImageIndex > -1)
and (Assigned(PopupMenu.Images))
then
begin
mBitmap := TBitmap.Create;
try
PopupMenu.Images.GetBitmap(MnuItm.ImageIndex,mBitmap);
aMenuBitmaps[ArrayPos].Canvas.StretchDraw(Rect(0,0,13,13),mBitmap);
finally
mBitmap.Free;
end;
end;
SetMenuItemBitmaps(APIMenu,MnuID,MF_BYCOMMAND,aMenuBitmaps[ArrayPos].Handle,aMenuBitmaps[ArrayPos].Handle);
Inc(ArrayPos);
end;
begin
Result := 0;
if CanAddLine
then
AppendMenu(APIMenu,MF_SEPARATOR,0,
nil);
ix := 0;
while ix < Item.Count
do
begin
Inc(Result);
Application.ProcessMessages;
if Item.Items[ix].Visible
then
begin
// Item hinzufügen
if Item.Items[ix].Count > 0
then
begin // Untermenü erstellen, falls nötig
SubMenu := CreatePopupMenu;
Inc(Result,AddVCLMenuItems(SubMenu,ID,Item.Items[ix],false,ArrayPos));
AppendMenu(APIMenu,GetItemFlags(Item.Items[ix])
or MF_POPUP,SubMenu,PChar(Item.Items[ix].Caption));
// Check und RadioItem hinzufügen
if Item.Items[ix].
Default then
SetMenuDefaultItem(APIMenu,ID,0);
if (Item.Items[ix].Checked)
and (Item.Items[ix].RadioItem)
then
CheckMenuRadioItem(APIMenu,ID,ID,ID,MF_BYCOMMAND);
// Bitmap hinzufügen
if ((Assigned(Item.Items[ix].Bitmap))
and (
not Item.Items[ix].Bitmap.Empty))
or
((Assigned(PopupMenu.Images))
and (Item.Items[ix].ImageIndex > -1))
and
(
not Item.Items[ix].Checked)
then
AddMenuBitmap(ID,Item.Items[ix]);
Inc(ID);
end
else
begin // Menüeintrag hinzufügen
AppendMenu(APIMenu,GetItemFlags(Item.Items[ix]),ID,PChar(Item.Items[ix].Caption));
// Check und RadioItem hinzufügen
if Item.Items[ix].
Default then
SetMenuDefaultItem(APIMenu,ID,0);
if (Item.Items[ix].Checked)
and (Item.Items[ix].RadioItem)
then
CheckMenuRadioItem(APIMenu,ID,ID,ID,MF_BYCOMMAND);
// Bitmap hinzufügen
if ((Assigned(Item.Items[ix].Bitmap))
and (
not Item.Items[ix].Bitmap.Empty))
or
((Assigned(PopupMenu.Images))
and (Item.Items[ix].ImageIndex > -1))
and
(
not Item.Items[ix].Checked)
then
AddMenuBitmap(ID,Item.Items[ix]);
end;
end;
Inc(ID);
Inc(ix);
end;
end;
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
// VCL Menüeinträge
iID := 1;
iRes := AddVCLMenuItems(mPopup,iID,PopupMenu.Items,true,0);
iHandlerCount := GetMenuItemCount(mPopup);
// Einfügeposition korrigieren
// Wichtig! Da sonst die "Senden an" Menüeinträge in das falsche
// Untermenü gezeichnet werden!
if (HandlerIndex > PopupMenu.Items.Count)
then
HandlerIndex := PopupMenu.Items.Count;
if (PopupMenu.Items.Count > 0)
and (HandlerIndex < PopupMenu.Items.Count)
then
if PopupMenu.Items[HandlerIndex].Count > 0
then
while (HandlerIndex < PopupMenu.Items.Count)
and
(PopupMenu.Items[HandlerIndex].Count > 0)
do
Inc(HandlerIndex);
// Handler hinzufügen
iCmdLast := 0;
iFlags := CMF_NORMAL;
case MenuType
of
smkOnlyHandler:
begin
iCmdLast := 0;
iFlags := CMF_NORMAL;
end;
smkComplete:
begin
iCmdLast := $7FFF;
iFlags := CMF_NORMAL;
end;
smkDefaultOnly:
begin
iCmdLast := $7FFF;
iFlags := CMF_DEFAULTONLY;
end;
smkNoDefault:
begin
iCmdLast := $7FFF;
iFlags := CMF_NODEFAULT;
end;
end;
OLECheck(mContextMenu.QueryContextMenu(mPopup, HandlerIndex + 1, HandlerIndex + 1, iCmdLast, iFlags));
OLECheck(mContextMenu.QueryInterface(IID_IContextMenu2, mContextMenu2));
try
iHandlerCount := GetMenuItemCount(mPopup) - iHandlerCount + 1;
if PopupMenu.Items.Count > 0
then
iHandlerIndex := HandlerIndex
else
iHandlerIndex := 0;
iCmd := Integer(TrackPopupMenuEx(mPopup, TPM_LEFTALIGN
or
TPM_RIGHTBUTTON
or TPM_HORIZONTAL
or TPM_VERTICAL
or TPM_RETURNCMD, X, Y,
Handle,
nil));
if not (iCmd
in [0..iRes])
then
Dec(iCmd,HandlerIndex);
// "OnClick" Ereignisse ausführen
if (MenuType <> smkOnlyHandler)
and (iCmd = 1)
and
(PopupMenu.Items.Count > 0)
then
PopupMenu.Items[0].Click
else
if iCmd <> 0
then
begin
if (ValidCmdArea)
or (MenuType = smkDefaultOnly)
or
(MenuType = smkNoDefault)
or (PopupMenu.Items.Count = 0)
then
begin // OnClick des Shell Menus
FillChar(mCmdInfo, SizeOf(mCmdInfo), 0);
with mCmdInfo
do
begin
cbSize := SizeOf(TCMInvokeCommandInfo);
lpVerb := MakeIntResource(iCmd - 1);
nShow := SW_SHOWNORMAL;
end;
try
if not Succeeded(mContextMenu.InvokeCommand(mCmdInfo))
then
begin // Wenn die Ausführung fehlgeschlagen ist
iID := 1;
ExecMenuItemAction(iCmd,iID,PopupMenu.Items);
end;
except
// nichts tun
end;
end
else
begin // VCL OnClick ausführen
iID := 1;
ExecMenuItemAction(iCmd,iID,PopupMenu.Items);
end;
end;
finally
mContextMenu :=
nil;
mContextMenu2 :=
nil;
end;
finally
DestroyMenu(mPopup);
end;
end;
// Wenn der Benutzer mit der rechten Maustaste klickt Menü anzeigen
procedure TForm1.PopupMenu1Popup(Sender: TObject);
begin
DestroyMenu((Sender
as TPopupMenu).Handle);
ContextMenuForFile('
C:\Eigene Dateien\_Test\Test.txt',3,Mouse.CursorPos.x,
Mouse.CursorPos.y,
Handle,(Sender
as TPopupMenu),smkComplete);
end;
procedure TForm1.WndProc(
var Message: TMessage);
var
iMenuPos: Integer;
begin
case Message.Msg
of
WM_MENUSELECT:
begin
// Prüfen, ob das Owner Draw Shell Popup Menü (mPopupMenu2) gezeichnet werden kann
iMenuPos := Integer(MenuItemFromPoint(
Handle,HMENU(
Message.LParam),TPoint(Mouse.CursorPos)));
if GetSubMenu(HMENU(
Message.LParam),iMenuPos) > 0
then
CanDraw := iMenuPos
in [(iHandlerIndex)..(iHandlerIndex + iHandlerCount)];
ValidCmdArea := CanDraw;
inherited WndProc(
Message);
end;
WM_INITMENUPOPUP,
WM_DRAWITEM,
WM_MENUCHAR,
WM_MEASUREITEM:
begin
// Owner Draw Shell Popup Menü zeichnen
if (Assigned(mContextMenu2))
and (CanDraw)
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;