Desplegar menú para TButton

Question

estoy tratando de simular un menú desplegable para un TButton, como se muestra a continuación:

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; 

El problema es que cuando el menú se deja caer hacia abajo, si hago clic en el botón otra vez quisiera que el menú se cerrara, pero en lugar de eso, vuelve a caer.

Estoy buscando una solución específicamente para Delphi genérico TButton sin equivalente de terceros.

Answer 1

Después de nuestra discusión (Vlad & I), se utiliza una variable para saber cuando se abrió el pasado la ventana emergente para elegir si visualiza el popupmenu o cancelar el evento de ratón:

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

Después de revisar la solución proporcionada por Whiler & Vlad, y comparándolo con la forma WinSCP implementa la misma cosa, actualmente estoy usando el siguiente código:

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. 

tiene la ventaja de no requerir ningún cambio de código a partir de la, además de callos ng ButtonMenu() en el manejador de onClick:

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