Delphi 是否在菜单项上检测鼠标左/右键单击？

在Delphi XE2中，如何检测用户是用鼠标左键还是右键单击弹出菜单项？

弹出菜单处理在Windows的

user32.dll

函数中进行。作为对左键或右键单击的响应，将生成

WM_命令

消息，该消息由Delphi VCL框架代码处理。

wParam

参数包含正在执行的菜单项的索引，

LParam

似乎始终为零

创建对左键和右键单击做出不同响应的菜单的唯一方法是自己生成弹出菜单，而不是从Windows生成

如果Windows的设计者决定将此信息作为窗口消息内的WParam或LParam的一部分传递给您，您可能已经做了一些事情，或者如果您可以钩住作为弹出菜单窗口消息循环一部分的鼠标按下事件，您也可以这样做，但我不知道这样做的可靠方法

---

如果您真的需要对左键和右键单击的菜单进行不同的处理，那么创建自己的弹出菜单可能会少一些工作。但是没有用户知道如何使用您的应用程序。对于标准Win32菜单，不推荐使用这种方法，事实上，据我所知，这是不可能的。

使用此单元，将其作为一个组件安装，并替换标准的

TPopupMenu

，它添加了一个

OnMenuRightClick

事件

unit RCPopupMenu;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus;

type
  TMenuRightClickEvent = procedure (Sender: TObject; Item: TMenuItem) of object;

  TRCPopupList = class(TPopupList)
  protected
    procedure WndProc(var Message: TMessage); override;
  end;

  TRCPopupMenu = class(TPopupMenu)
  private
    FOnMenuRightClick: TMenuRightClickEvent;
  protected
    function DispatchRC(aHandle: HMENU; aPosition: Integer): Boolean;
    procedure RClick(aItem: TMenuItem);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Popup(X, Y: Integer); override;
  published
    property OnMenuRightClick: TMenuRightClickEvent read FOnMenuRightClick write FOnMenuRightClick;
  end;

procedure Register;

var
  RCPopupList: TRCPopupList;

implementation

procedure Register;
begin
  RegisterComponents('Samples', [TRCPopupMenu]);
end;

{ TRCPopupList }

procedure TRCPopupList.WndProc(var Message: TMessage);
var
  i: Integer;
  pm: TPopupMenu;
begin
  if Message.Msg = WM_MENURBUTTONUP then
  begin
    for I := 0 to Count - 1 do
    begin
      pm := TPopupMenu(Items[i]);
      if pm is TRCPopupMenu then
        if TRCPopupMenu(Items[i]).DispatchRC(Message.lParam, Message.wParam) then
          Exit;
    end;
  end;
  inherited WndProc(Message);
end;

{ TRCPopupMenu }

constructor TRCPopupMenu.Create(AOwner: TComponent);
begin
  inherited;
  PopupList.Remove(Self);
  RCPopupList.Add(Self);
end;

destructor TRCPopupMenu.Destroy;
begin
  RCPopupList.Remove(Self);
  PopupList.Add(Self);
  inherited;
end;

function TRCPopupMenu.DispatchRC(aHandle: HMENU; aPosition: Integer): Boolean;
begin
  Result := False;
  if Handle = aHandle then
  begin
    RClick(Items[aPosition]);
    Result := True;
  end;
end;

procedure TRCPopupMenu.Popup(X, Y: Integer);
const
  Flags: array[Boolean, TPopupAlignment] of Word =
    ((TPM_LEFTALIGN, TPM_RIGHTALIGN, TPM_CENTERALIGN),
    (TPM_RIGHTALIGN, TPM_LEFTALIGN, TPM_CENTERALIGN));
  Buttons: array[TTrackButton] of Word = (TPM_RIGHTBUTTON, TPM_LEFTBUTTON);
var
  AFlags: Integer;
begin
  DoPopup(Self);
  AFlags := Flags[UseRightToLeftAlignment, Alignment] {or Buttons[TrackButton]};
  if (Win32MajorVersion > 4) or ((Win32MajorVersion = 4) and (Win32MinorVersion > 0)) then
  begin
    AFlags := AFlags or (Byte(MenuAnimation) shl 10);
    AFlags := AFlags or TPM_RECURSE;
  end;
  TrackPopupMenuEx(Items.Handle, AFlags, X, Y, RCPopupList.Window, nil);
end;

procedure TRCPopupMenu.RClick(aItem: TMenuItem);
begin
  if Assigned (FOnMenuRightClick) then
    FOnMenuRightClick(Self, aItem);
end;

var
  oldPL: TPopupList;

initialization
  RCPopupList := TRCPopupList.Create;
finalization
  RCPopupList.Free;

end.

然后，您可以使用

OnMenuRightClick

事件对右键单击执行一些操作

---

注意：我没有制作这个单元-我不知道是谁制作的，但功劳归谁。。。不过，我刚刚在Delphi XE2中对其进行了测试，效果很好。

多亏了TLama和该代码的作者！非常有用，但只需要一个小的更新： 这个过程只是检查第一级的项目，如果你的菜单包含子项目，它就不起作用了。。。 因此，我们必须重载DispatchRC函数，对单击的项进行递归搜索。 我做到了，效果很好：

function TRCPopupMenu.DispatchRC(aHandle: HMENU; aPosition: Integer): Boolean;
begin
  //Result := False; // freezebit : now, unused value
  if Handle = aHandle then
  begin
    RClick(Items[aPosition]);
    Result := True;
    Exit; // freezebit : found, so leave
  end;
  Result := DispatchRC(aHandle, aPosition, Items); // freezebit : now make a recursive search in all sub-items
end;

// freezebit : this function search in all sub-items recursively if we found the right-clicked TMenuItem
function TRCPopupMenu.DispatchRC(aHandle: HMENU; aPosition: Integer; aItems: TMenuItem): Boolean;
var
  i: integer;
  itm: TMenuItem;
begin
  Result := False;
  for i := 0 to aItems.Count - 1 do begin
    itm := aItems[i];
    if itm.Count = 0 then
      Continue;
    if itm.Items[0].Parent.Handle = aHandle then begin
      RClick(itm.Items[aPosition]);
      Result := True;
      Exit;
    end;
    if DispatchRC(aHandle, aPosition, itm) then begin
      Result := True;
      Exit;
    end;
  end;
end;

---

多亏了作者和FriezBit，但我认为这个解决方案有点漂亮（也更改了DispatchRC）：

函数TRCPopupMenu.DispatchRC（aHandle:humenu；aPosition:Integer）：布尔；
var FParentItem:TMenuItem；
开始
结果：=假；
如果Handle=aHandle，则
FParentItem:=项目
其他的
FParentItem:=FindItem（aHandle，fkHandle）；
如果FParentItem为零，则
开始
单击（FParentItem.Items[aPosition]）；
结果：=真；
结束；
{如果Handle=aHandle，则
开始
单击（项目[位置]）；
结果：=真；
结束；}
结束；

有趣-我2分钟前在以下位置发现了相同的组件：

function TRCPopupMenu.DispatchRC(aHandle: HMENU; aPosition: Integer): Boolean;
var FParentItem: TMenuItem;
begin
  Result := False;
  if Handle = aHandle then
    FParentItem := Items
  else
    FParentItem := FindItem(aHandle, fkHandle);
  if FParentItem <> nil then
    begin
      RClick(FParentItem.Items[aPosition]);
      Result := True;
    end;
{  if Handle = aHandle then
  begin
    RClick(Items[aPosition]);
    Result := True;
  end;}
end;