Explorer Popup

[scp]

So, habs raus, da ist tatsächlich ne WndProc nötig:

Delphi-Quellcode:

type
  TForm1 = class(TForm)
//...
    procedure WndProc(var Message: TMessage); override;
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;
//...

implementation

{$R *.dfm}

uses
  ComObj, ShlObj, ActiveX;

function SlashDirName(ADir: String): String;
//wie oben
//...

function SHGetIDListFromPath(Path: TFileName; var ShellFolder: IShellFolder): PItemIDList;
//wie oben
//...

var
  aContextMenu: IContextMenu;
  aContextMenu2: IContextMenu2;

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)));
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:=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.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;

procedure TForm1.FormCreate(Sender: TObject);
begin
  aContextMenu2 := nil;
end;