Drop down menu for any TControl

Question

Continue of this topic:

Drop down menu for TButton

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;

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

BUT does not work as expected with 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;

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?

Answer 1

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:

• The click cancels the modal menu loop, the menu is closed and a mouse down message is posted.
• VCL sets a flag within the mouse down message handling [csClicked].
• Mouse down event handler is fired, you release the capture.
• After the mouse down message returns, posted mouse up message is processed, VCL checks for the flag and clicks the control if it is set.
• The click handler pops the menu.

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;

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.