delphi - 任何 TControl 的下拉菜单

Question

继续这个主题:

Drop down menu for TButton

我已经用 any TControl 为 DropDown memu 编写了通用代码，但由于某种原因，它无法按预期与 TPanel 一起工作:

var
  TickCountMenuClosed: Cardinal = 0;
  LastPopupControl: TControl;

type
  TDropDownMenuHandler = class
  public
    class procedure MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  end;                            
  TControlAccess = class(TControl);

class procedure TDropDownMenuHandler.MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if LastPopupControl <> Sender then Exit;
  if (Button = mbLeft) and not ((TickCountMenuClosed + 100) < GetTickCount) then
  begin
    if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
    ReleaseCapture;
    // SetCapture(0);
    if Sender is TGraphicControl then Abort;
  end;
end;

procedure RegisterControlDropMenu(Control: TControl; PopupMenu: TPopupMenu);
begin
  TControlAccess(Control).OnMouseDown := TDropDownMenuHandler.MouseDown;
end;

procedure DropMenuDown(Control: TControl; PopupMenu: TPopupMenu);
var
  APoint: TPoint;
begin
  LastPopupControl := Control;
  RegisterControlDropMenu(Control, PopupMenu);
  APoint := Control.ClientToScreen(Point(0, Control.ClientHeight));
  PopupMenu.PopupComponent := Control;
  PopupMenu.Popup(APoint.X, APoint.Y);
  TickCountMenuClosed := GetTickCount;
end;

这适用于 TButton 和 TSpeedButton 以及任何 TGraphicControl(例如 TImage 或 据我所知，TSpeedButton 等)。

但是 TPanel 无法按预期工作

procedure TForm1.Button1Click(Sender: TObject);
begin
  DropMenuDown(Sender as TControl, PopupMenu1);
end;

procedure TForm1.Panel1Click(Sender: TObject);
begin
  DropMenuDown(Sender as TControl, PopupMenu1); // Does not work!
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  DropMenuDown(Sender as TControl, PopupMenu1);
end;

procedure TForm1.Image1Click(Sender: TObject);
begin
  DropMenuDown(Sender as TControl, PopupMenu1);
end;

似乎TPanel不尊重ReleaseCapture;，甚至不尊重事件TDropDownMenuHandler.MouseDown中的Abort。我该怎么做才能使其与 TPanel 和其他控件一起使用？我错过了什么？

Answer 1

这并不是说 TPanel 不尊重 ReleaseCapture，而是捕获根本不相关。这是弹出菜单启动并处于事件状态并再次单击控件后发生的情况:

• 单击会取消模式菜单循环，关闭菜单并发布一条鼠标按下消息。
• VCL 在鼠标按下消息处理中设置一个标志[csClicked]。
• 鼠标按下事件处理程序被触发，您释放捕获。
• 鼠标按下消息返回后，处理发布的鼠标抬起消息，VCL 检查标志并单击控件(如果已设置)。
• 点击处理程序会弹出菜单。

当然，我没有跟踪工作示例，因此我无法判断 ReleaseCapture 何时以及如何提供帮助。无论如何，它在这里帮不上忙。

<小时/>

我提出的解决方案与当前的设计略有不同。

我们想要的是第二次点击而不是引起点击。看这部分代码:

procedure DropMenuDown(Control: TControl; PopupMenu: TPopupMenu);
var
  APoint: TPoint;
begin
  ...
  PopupMenu.PopupComponent := Control;
  PopupMenu.Popup(APoint.X, APoint.Y);
  TickCountMenuClosed := GetTickCount;
end;

实际上，第二次单击会关闭菜单，然后再通过同一处理程序再次启动菜单。这是导致 PopupMenu.Popup 调用返回的原因。所以我们在这里可以知道的是，鼠标按钮被单击(左键或双击)，但尚未被 VCL 处理。这意味着该消息仍在队列中。

用这种方法删除注册机制(鼠标按下处理程序黑客攻击)，这是不需要的，并且类本身和全局变量也是不需要的。

procedure DropMenuDown(Control: TControl; PopupMenu: TPopupMenu);
var
  APoint: TPoint;
  Msg: TMsg;
  Wnd: HWND;
  ARect: TRect;
begin
  APoint := Control.ClientToScreen(Point(0, Control.ClientHeight));
  PopupMenu.PopupComponent := Control;
  PopupMenu.Popup(APoint.X, APoint.Y);

  if (Control is TWinControl) then
    Wnd := TWinControl(Control).Handle
  else
    Wnd := Control.Parent.Handle;
  if PeekMessage(Msg, Wnd, WM_LBUTTONDOWN, WM_LBUTTONDBLCLK, PM_NOREMOVE) then begin
    ARect.TopLeft := Control.ClientOrigin;
    ARect.Right := ARect.Left + Control.Width;
    ARect.Bottom := ARect.Top + Control.Height;
    if PtInRect(ARect, Msg.pt) then
      PeekMessage(Msg, Wnd, WM_LBUTTONDOWN, WM_LBUTTONDBLCLK, PM_REMOVE);
  end;
end;

此外，这不依赖于处理时间。