Drop-down menu for TButton

Question

I am trying to simulate a dropdown menu for TButton as shown below:

procedure DropMenuDown(Control: TControl; PopupMenu: TPopupMenu); var APoint: TPoint; begin APoint := Control.ClientToScreen(Point(0, Control.ClientHeight)); PopupMenu.Popup(APoint.X, APoint.Y); end; procedure TForm1.Button1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Button = mbLeft then begin DropMenuDown(Button1, PopupMenu1); // ReleaseCapture; end; end; 

The problem is that when the menu pops up, if I press the button again, I need to close the menu, but instead it drops again.

I am looking for a solution specifically for the general Delphi TButton , and not for a third-party equivalent.

Answer 1

After our discussion (Vlad and I), you use a variable to know when the popup was last opened if you select popupmenu or cancel the mouse event:

 unit Unit4; interface uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Menus, Vcl.StdCtrls; type TForm4 = class(TForm) PopupMenu1: TPopupMenu; Button1: TButton; fgddfg1: TMenuItem; fdgdfg1: TMenuItem; procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); procedure Button1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); private { Private declarations } cMenuClosed: Cardinal; public { Public declarations } end; var Form4: TForm4; implementation {$R *.dfm} procedure DropMenuDown(Control: TControl; PopupMenu: TPopupMenu); var APoint: TPoint; begin APoint := Control.ClientToScreen(Point(0, Control.ClientHeight)); PopupMenu.Popup(APoint.X, APoint.Y); end; procedure TForm4.Button1Click(Sender: TObject); begin DropMenuDown(Button1, PopupMenu1); cMenuClosed := GetTickCount; end; procedure TForm4.Button1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if (Button = mbLeft) and not ((cMenuClosed + 100) < GetTickCount) then begin ReleaseCapture; end; end; procedure TForm4.FormCreate(Sender: TObject); begin cMenuClosed := 0; end; end. 

Answer 2

After reviewing the solution provided by Whiler and Vlad, and comparing it with how WinSCP implements the same thing, I currently use the following code:

 unit ButtonMenus; interface uses Vcl.Controls, Vcl.Menus; procedure ButtonMenu(Control: TControl; PopupMenu: TPopupMenu); implementation uses System.Classes, WinApi.Windows; var LastClose: DWord; LastPopupControl: TControl; LastPopupMenu: TPopupMenu; procedure ButtonMenu(Control: TControl; PopupMenu: TPopupMenu); var Pt: TPoint; begin if (Control = LastPopupControl) and (PopupMenu = LastPopupMenu) and (GetTickCount - LastClose < 100) then begin LastPopupControl := nil; LastPopupMenu := nil; end else begin PopupMenu.PopupComponent := Control; Pt := Control.ClientToScreen(Point(0, Control.ClientHeight)); PopupMenu.Popup(Pt.X, Pt.Y); { Note: PopupMenu.Popup does not return until the menu is closed } LastClose := GetTickCount; LastPopupControl := Control; LastPopupMenu := PopupMenu; end; end; end. 

This has the advantage of not requiring any code changes other than calling ButtonMenu() in the onClick handler:

 procedure TForm1.Button1Click(Sender: TObject); begin ButtonMenu(Button1, PopupMenu1); end;