任何TControl的下拉菜单

Question

继续这个主题:

TButton的下拉菜单

我已经写了有下拉菜单是一个通用的代码的任何 TControl,但由于某种原因,剂量按预期工作不是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;,甚至不在Abort事件中TDropDownMenuHandler.MouseDown.我可以做些什么来使这个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;

另外,这不依赖于处理时序.