uShellContextMenu.pas

unit uShellContextMenu;

{$mode objfpc}{$H+}
// ShellContextMenu.cpp: Implementierung der Klasse CShellContextMenu.
// http://www.codeproject.com/KB/shell/shellcontextmenu.aspx
// updated version: http://www.codeproject.com/Messages/4971624/Please-get-this-updated-version-Tested-ok-on-windo.aspx

interface

uses
  Classes, SysUtils, Windows, activex, shlobj, Menus;

type
  TShellContextMenu = class
  private
    g_IContext2: IContextMenu2;
    g_IContext3: IContextMenu3;
    m_psfFolder: IShellFolder;
    m_pidlArray: array of PITEMIDLIST;
    fExtendedVerbs: boolean;
    procedure InvokeCommand(pContextMenu: IContextMenu; idCommand: uint);
    procedure ClearPidlArray;
    procedure Test(Sender: TObject);
    function GetMaxCommandId(menu: TMenuItem): Word;
  protected
    function GetContextMenu(out ppContextMenu: IContextMenu; out iMenuType: integer): boolean;
    procedure HookWndProc(var msg: TMessage);
  public
    constructor Create;
    destructor Destroy; override;

    procedure SetObjects(const Path: String);
    procedure SetObjects(const Paths: TStrings);
    property ExtendedVerbs: boolean read fExtendedVerbs write fExtendedVerbs;
    function ShowContextMenu(pt: TPOINT): UINT;
    function ShowContextMenu(aMenu: TPopupMenu; pt: TPOINT): UINT;
    function ShowContextMenu(aMenu: TPopupMenu; aItem: TMenuItem; pt: TPOINT): UINT;
  end;

implementation

uses
  uWindowSubclass, Win32Int;


{ TShellContextMenu }

constructor TShellContextMenu.Create;
begin
  inherited Create;
  m_pidlArray:= nil;
  m_psfFolder:= nil;
end;

destructor TShellContextMenu.Destroy;
begin
  // free all allocated datas
  m_psfFolder:= nil;
  ClearPidlArray;
  inherited Destroy;
end;

procedure TShellContextMenu.ClearPidlArray;
var
  i: integer;
begin
  for i:= 0 to high(m_pidlArray) do
    ILFree(m_pidlArray[i]);
  SetLength(m_pidlArray, 0);
end;


// this functions determines which version of IContextMenu is avaibale for those objects (always the highest one)
// and returns that interface
function TShellContextMenu.GetContextMenu(out ppContextMenu: IContextMenu; out iMenuType: integer): boolean;
var
  icm1: IContextMenu;
begin
  ppContextMenu:= nil;
  iMenuType:= 0;
  Result:= false;
  icm1:= nil;

  // first we retrieve the normal IContextMenu interface (every object should have it)
  if (Length(m_pidlArray)>0) and Assigned(m_psfFolder) then
    m_psfFolder.GetUIObjectOf(0, Length(m_pidlArray), m_pidlArray[0], IID_IContextMenu, nil, icm1);

  if Assigned(icm1) then begin
    // since we got an IContextMenu interface we can now obtain the higher version interfaces via that
    if Supports(icm1, IID_IContextMenu3, ppContextMenu) then
      iMenuType:= 3
    else
    if Supports(icm1, IID_IContextMenu2, ppContextMenu) then
      iMenuType:= 2
    else
      ppContextMenu:= icm1;

    Result:= true;
  end;
end;

procedure TShellContextMenu.HookWndProc(var msg : TMessage);
var
  res: LRESULT;
begin
  with msg do begin
    case msg of
      WM_MENUCHAR:
        if Assigned(g_IContext3) then begin // only supported by IContextMenu3
          res:= 0;
          g_IContext3.HandleMenuMsg2(msg,wparam,lparam,@res);
          result:= res;
        end;
      WM_DRAWITEM,
      WM_MEASUREITEM:
        if wparam = 0 then // if wParam != 0 then the message is not menu-related
          g_IContext2.HandleMenuMsg(msg, wparam, lparam);
      WM_INITMENUPOPUP: begin
        g_IContext2.HandleMenuMsg(msg, wparam, lparam);
        Result:= 1;
      end;
    else
      Result:= 0;
    end;
  end;
end;

procedure TShellContextMenu.Test(Sender:TObject);
begin
  MessageBox(0, 'Testnachricht', 'Testbox', 0);
end;


function TShellContextMenu.GetMaxCommandId(menu:TMenuItem): Word;
var
  i: integer;
  l: Word;
begin
  Result:= menu.Command;
  for i:= 0 to menu.Count - 1 do begin
    l:= GetMaxCommandId(menu.Items[i]);
    if l > Result then
      Result:= l;
  end;
end;


function TShellContextMenu.ShowContextMenu(aMenu: TPopupMenu; aItem: TMenuItem; pt: TPOINT): UINT;
var
  iMenuType: integer;
  pContextMenu: IContextMenu;
  idFirstCommand, idCommand: uint;
  cmflags: uint;
  bInsertedFakeItem: Boolean;
begin
  Result:= 0;
  if not GetContextMenu(pContextMenu, iMenuType) then
    exit;

  if (aItem.Count = 0) and (aItem <> aMenu.Items) then begin
    // LCL menus don't really understand subitems if their .Count is 0
    bInsertedFakeItem:= true;
    aItem.Add(TMenuItem.Create(aItem));
    aItem.Items[0].Visible:= false;
  end else
    bInsertedFakeItem:= false;

  idFirstCommand:= GetMaxCommandId(aItem) + 1;

  cmflags:= CMF_NORMAL or CMF_EXPLORE;
  if fExtendedVerbs then
    cmflags:= cmflags or CMF_EXTENDEDVERBS;

  // lets fill the our popupmenu
  aMenu.HandleNeeded;
  pContextMenu.QueryContextMenu(aItem.Handle, aItem.Count, idFirstCommand, high(Word) - 1, cmflags);

  // subclass window to handle menurelated messages in CShellContextMenu
  if iMenuType > 1 then begin // only subclass if its version 2 or 3
    SubclassWindow(Win32WidgetSet.AppHandle, @HookWndProc);
    if iMenuType > 2 then
      g_IContext3:= pContextMenu as IContextMenu3;
    g_IContext2:= pContextMenu as IContextMenu2;
  end;

  idCommand:= LongWord(TrackPopupMenu(aMenu.Handle, TPM_RETURNCMD or TPM_LEFTALIGN, pt.x, pt.y, 0, Win32WidgetSet.AppHandle, nil));

  // will only unsubclass if subclassed by this code
  UnsubclassWindow(Win32WidgetSet.AppHandle, nil);

  // see if returned idCommand belongs to shell menu entries
  if (idCommand> idFirstCommand) and (idCommand < high(Word)) then begin
    InvokeCommand(pContextMenu, idCommand - idFirstCommand); // execute related command
    idCommand:= 0;
  end else
    aMenu.DispatchCommand(idCommand);
  Result:= idCommand;

  if bInsertedFakeItem then
    aItem.Delete(0);
  aMenu.DestroyHandle;

  g_IContext3:= nil;
  g_IContext2:= nil;
end;

function TShellContextMenu.ShowContextMenu(aMenu: TPopupMenu; pt: TPOINT): UINT;
begin
  Result:= ShowContextMenu(aMenu, aMenu.Items, pt);
end;

function TShellContextMenu.ShowContextMenu(pt: TPOINT): UINT;
var
  menu: TPopupMenu;
begin
  menu:= TPopupMenu.Create(nil);
  try
    Result:= ShowContextMenu(menu, pt);
  finally
    FreeAndNil(menu);
  end;
end;

procedure TShellContextMenu.InvokeCommand(pContextMenu: IContextMenu; idCommand: uint);
var
  cmi: TCMINVOKECOMMANDINFO;
begin
  ZeroMemory(@cmi, sizeof(cmi));
  cmi.cbSize:= sizeof(cmi);
  cmi.lpVerb:= MakeIntResource(idCommand);
  cmi.nShow:= SW_SHOWNORMAL;
  pContextMenu.InvokeCommand(cmi);
end;

procedure TShellContextMenu.SetObjects(const Path: String);
var
  list: TStringList;
begin
  list:= TStringList.Create;
  try
    list.Add(Path);
    SetObjects(list);
  finally
    FreeAndNil(list);
  end;
end;

function SHBindToParent2(pidl:LPCITEMIDLIST; constref riid:TREFIID; var ppv:Pointer; var ppidlLast:LPCITEMIDLIST):HRESULT;StdCall;external External_library name 'SHBindToParent';

procedure TShellContextMenu.SetObjects(const Paths: TStrings);
var
  idl, idlItem: PITEMIDLIST;
  malloc: IMalloc;
  psfFolder: IShellFolder;
  i: integer;
begin
  m_psfFolder:= nil;
  ClearPidlArray;

  if Paths.Count = 0 then
    exit;

  SHGetMalloc(malloc);

  idl:= ILCreateFromPath(LPCSTR(Paths[0]));
  idlItem:= nil;
  // now we need the parent IShellFolder interface of pidl, and the relative PIDL to that interface
  SHBindToParent2(idl, IID_IShellFolder, Pointer(m_psfFolder), idlItem);
  // get interface to IMalloc (need to free the PIDLs allocated by the shell functions)
  malloc.Free(idl);

  // now we have the IShellFolder interface to the parent folder specified in the first element in strArray
  // since we assume that all objects are in the same folder (as it's stated in the MSDN)
  // we now have the IShellFolder interface to every objects parent folder

  psfFolder:= nil;
  SetLength(m_pidlArray, Paths.Count);
  for i:= 0 to Paths.Count - 1 do begin
    idl:= ILCreateFromPath(LPCSTR(Paths[i]));
    SHBindToParent2(idl, IID_IShellFolder, Pointer(psfFolder), idlItem);
    m_pidlArray[i]:= ILClone(idlItem);
    malloc.Free(idl);
    psfFolder:= nil;
  end;
end;


end.