任何 TControl 的下拉菜单 [英] Drop down menu for any TControl

问题描述

继续这个话题:

TButton 的下拉菜单

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

I have wrote a generic code for DropDown memu with any TControl, but for some reason it dose not work as expected with 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 等)据我所知.

This works well with TButton and with TSpeedButton and with any TGraphicControl (like TImage or TSpeedButton etc) as far as I can tell.

但是在 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; 甚至Abort 在事件TDropDownMenuHandler.MouseDown 中.我该怎么做才能使 TPanel 和其他控件能够正常工作?我错过了什么?

Seems like TPanel is not respecting ReleaseCapture; and not even Abort in the event TDropDownMenuHandler.MouseDown. What can I do to make this work with TPanel and other controls? What am I missing?

推荐答案

并不是TPanel不尊重ReleaseCapture，而是捕获根本不相关.这是弹出菜单启动并激活后发生的情况，再次单击控件:

It's not that TPanel is not respecting ReleaseCapture, it is that the capture is not relevant at all. This is what happens after the popup menu is launched and active, and the control is clicked once again:

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

当然，我没有追踪一个工作示例，所以我不知道 ReleaseCapture 何时以及如何有帮助.无论如何，它在这里无济于事.

Granted I didn't trace a working example so I can't tell when and how ReleaseCapture is helpful. In any case, it can't help here.

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

The solution I'd propose is a little different than the current design.

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

What we want is a second click to not to cause a click. See this part of the code:

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 处理.这意味着消息还在队列中.

The second click is in fact what closes the menu, before launching it again through the same handler. It is what causes the PopupMenu.Popup call to return. So what we can tell here is that the mouse button is clicked (either a left button or a double click), but not yet processed by the VCL. That means the message is yet in the queue.

用这种方法删除注册机制(鼠标按下处理程序黑客)，它是不需要的，结果是类本身，以及全局变量.

Remove the registration mechanism (mouse down handler hacking) with this approach, it is not needed, and the class itself as a result, and the globals.

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;

此外，这不取决于处理时间.

Additionally this doesn't depend on processing timing.

这篇关于任何 TControl 的下拉菜单的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！