ContextMenuHandlers in eigene PopupMenüs einbinden

[franz]

Das eine Problem ist noch nicht gelöst. So lange keine eigenen Menüeinträge hinzugefügt werden oder das Menü mit der Maus bedient wird, funktioniert es zumindest mit Windows 98.

Ich habe folgendes geschrieben:

Delphi-Quellcode:

…
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;

Das Menü braucht nicht extra aufgerufen werden. Wenn der Benutzer die rechte Maustaste drückt wird das Menü angezeigt.

Allerdings muss folgende Ereignisbehandlungsroutine für „OnPopup“ (bei TPopupMenu) oder „OnBeforePopup“ (bei TFJFPopupMenu) geschrieben werden:

Delphi-Quellcode:

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),smkOnlyHandler);
end;

Der letzte Parameter von „ContextMenuForFile“ gibt an, welcher Teil des Shell Menüs angezeigt werden soll.

Zugegeben es ist etwas viel geworden, aber wenigstens funktioniert es einigermaßen.

Der nächste Schritt ist die Erstellung einer Komponente. Allerdings muss die Komponente „WndProc“ von „TForm“ überschreiben, damit diese funktioniert. Ich habe schon einiges probiert. Mit „TApplication.OnMessage“ funktioniert es nicht und mit einem Hook stürzt Windows ab!

Vielleicht hat jemand eine Idee.

PS: Bitte lasst mich nicht wieder hängen. Auch wenn Ihr keine Lösung wisst bitte meldet euch, dann weiß ich wenigstens, dass dieses Thema von jemandem gelesen wird.