delphi – 任何TControl的下拉菜单

继续这个主题：

我已经用任何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);
    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和其他控件？我错过了什么？

解决方法

这并不是说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,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,PM_REMOVE);
  end;
end;

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

delphi – 任何TControl的下拉菜单

解决方法

猜你在找的Delphi相关文章