IContextMenu - jak dodać podmenu

Na bazie przykładu z delphi

plik ContSMenu.dpr

// This COM server defines a Context Menu shell extension.  This allows the user
// to right click on Delphi Project files (.DPR) from the Explorer and compile
// them using the DCC32.exe command line compiler.

library ContSMenu;

uses
  ComServ,
  ContextSM in 'ContextSM.pas';

exports
  DllGetClassObject,
  DllCanUnloadNow,
  DllRegisterServer,
  DllUnregisterServer;

begin
end.

//Context Submenu example based on Context Menu Example from Delphi Demos
//2008.10.02 - [email protected]
unit ContextSM;

interface

uses
  Windows, ActiveX, ComObj, ShlObj, Dialogs;

type
  TContextMenu = class(TComObject, IShellExtInit, IContextMenu)
  private
    FFileName: array[0..MAX_PATH] of Char;
  protected
    { IShellExtInit }
    function IShellExtInit.Initialize = SEIInitialize; // Avoid compiler warning
    function SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
      hKeyProgID: HKEY): HResult; stdcall;
    { IContextMenu }
    function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast,
      uFlags: UINT): HResult; stdcall;
    function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
    function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
      pszName: LPSTR; cchMax: UINT): HResult; stdcall;
  end;

const
  Class_ContextMenu: TGUID = '{34F3EB16-59CE-4B1A-855C-BAE2ECD3FA09}';

implementation

uses ComServ, SysUtils, ShellApi, Registry;

//to potrzebne aby uzyskac nazwe pliku dla ktorego wywolano ( w uproszczeniu)
function TContextMenu.SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
  hKeyProgID: HKEY): HResult;
var
  StgMedium: TStgMedium;
  FormatEtc: TFormatEtc;
begin
  // Fail the call if lpdobj is Nil.
  if (lpdobj = nil) then begin
    Result := E_INVALIDARG;
    Exit;
  end;

  with FormatEtc do begin
    cfFormat := CF_HDROP;
    ptd      := nil;
    dwAspect := DVASPECT_CONTENT;
    lindex   := -1;
    tymed    := TYMED_HGLOBAL;
  end;

  // Render the data referenced by the IDataObject pointer to an HGLOBAL
  // storage medium in CF_HDROP format.
  Result := lpdobj.GetData(FormatEtc, StgMedium);
  if Failed(Result) then
    Exit;
  // If only one file is selected, retrieve the file name and store it in
  // FFileName. Otherwise fail the call.
  if (DragQueryFile(StgMedium.hGlobal, $FFFFFFFF, nil, 0) = 1) then begin
    DragQueryFile(StgMedium.hGlobal, 0, FFileName, SizeOf(FFileName));
    Result := NOERROR;
  end
  else begin
    FFileName[0] := #0;
    Result := E_FAIL;
  end;
  ReleaseStgMedium(StgMedium);
end;


function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst,
          idCmdLast, uFlags: UINT): HResult;
var
 hSubmenu:HMENU;
 id:Integer;
 mii:MENUITEMINFOA;
begin
  Result := 0; // or use MakeResult(SEVERITY_SUCCESS, FACILITY_NULL, 0);

              
  if ((uFlags and $0000000F) = CMF_NORMAL) or  ((uFlags and CMF_EXPLORE) <> 0) then begin
    // Add one menu item to context menu with submenus

    //First create popupmenu
    hSubmenu := CreatePopupMenu();
    id := idCmdFirst;


    //dodajemy submenu
    InsertMenu(hSubmenu, 0, MF_BYPOSITION, id, 'Pierwsze');
    inc(id);
    InsertMenu(hSubmenu, 1, MF_BYPOSITION, id, 'Drugie');
    inc(id);


    //oraz menu glowne
    FillChar(mii,sizeof(mii),0);

    mii.cbSize := sizeof(mii);
    mii.fMask := MIIM_SUBMENU or MIIM_ID or MIIM_TYPE or MIIM_STATE;
    mii.wID := id;
    mii.hSubMenu := hSubmenu;
    mii.fType := MFT_STRING;
    mii.fState := MFS_ENABLED;
    mii.dwTypeData := 'Submenu';
    inc(id);

    if (not InsertMenuItem(Menu, indexMenu, LongBool(True),  mii)) then
    begin
    //Error ....
    end;


   // Return number of menu items added
    Result := MakeResult(SEVERITY_SUCCESS, 0, id-idCmdFirst);
  end;
end;

function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
begin
  Result := E_FAIL;
  // Make sure we are not being called by an application
  if (HiWord(Integer(lpici.lpVerb)) <> 0) then
  begin
    Exit;
  end;

  //ten argument musi byc w zakresie naszych menu ID, znajduje sie ono w LoWord(Integer(lpici.lpVerb))
  // Make sure we aren't being passed an invalid argument number
  if (LoWord(lpici.lpVerb) > 2{high menu id}) then begin
    Result := E_INVALIDARG;
    Exit;
  end;

  try
    MessageBox(0,PChar('Odpalono submenu nr: '+IntToStr(LoWord(Integer(lpici.lpVerb)))),'',0);
    Result := NOERROR;
  finally
  end;
end;

function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
  pszName: LPSTR; cchMax: UINT): HRESULT;
begin

//To mozna rozwinac na podmenu tez ....

  if (idCmd = 0) then begin
    if (uType = GCS_HELPTEXT) then
      // return help string for menu item
      StrCopy(pszName, 'Compile the selected Delphi project');
    Result := NOERROR;
  end
  else
    Result := E_INVALIDARG;
end;

type
  TContextMenuFactory = class(TComObjectFactory)
  public
    procedure UpdateRegistry(Register: Boolean); override;
  end;

procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
var
  ClassID: string;
begin
  if Register then begin
    inherited UpdateRegistry(Register);

    ClassID := GUIDToString(Class_ContextMenu);
    CreateRegKey('DelphiProject\shellex', '', '');
    CreateRegKey('DelphiProject\shellex\ContextMenuHandlers', '', '');
    CreateRegKey('DelphiProject\shellex\ContextMenuHandlers\ContMenu', '', ClassID);

    if (Win32Platform = VER_PLATFORM_WIN32_NT) then
      with TRegistry.Create do
        try
          RootKey := HKEY_LOCAL_MACHINE;
          OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions', True);
          OpenKey('Approved', True);
          WriteString(ClassID, 'Delphi Context Menu Shell Extension Example');
        finally
          Free;
        end;
  end
  else begin
    DeleteRegKey('DelphiProject\shellex\ContextMenuHandlers\ContMenu');
    DeleteRegKey('DelphiProject\shellex\ContextMenuHandlers');
    DeleteRegKey('DelphiProject\shellex');

    inherited UpdateRegistry(Register);
  end;
end;

initialization
  TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
    '', 'Delphi Context SubMenu(s) Shell Extension Example', ciMultiInstance,
    tmApartment);
end.