Как вы выстраиваете TPopupMenu так, чтобы он точно позиционировал себя над кнопкой?

Question

Я хочу, чтобы всплывающее меню выше кнопки:

Delphi облегает систему меню Win32 таким образом, что кажется, исключает каждый режим или флаг, лежащий в основе Win32 API предусматривает, что не было в VCL автора мозг в этот день. Одним из таких примеров является TPM_BOTTOMALIGN, который может быть передан в TrackPopupMenu, но, как представляется, оболочка Delphi делает это не только невозможным в запасе VCL, но и вредоносным использованием частных и защищенных методов невозможно (по крайней мере, мне кажется быть невозможным) делать либо точно во время выполнения, либо путем переопределения. Компонент VCL TPopupMenu также не очень хорошо разработан, так как он должен иметь виртуальный метод с именем PrepareForTrackPopupMenu, который сделал все, кроме вызова TrackPopupMenu или TrackPopupMenuEx, а затем разрешить кому-то переопределить метод, который фактически вызывает этот метод Win32. Но сейчас уже слишком поздно. Возможно, Delphi XE5 будет иметь это основное покрытие Win32 API, сделанное правильно.

подходов я пытался:

подхода: Использование METRICS или шрифты:

определяет высоту точно всплывающее меню, так что я могу вычесть значение Y перед вызовом popupmenu.Popup (х, у). Результаты: нужно было бы обрабатывать все варианты тематики Windows и делать предположения, о которых я, похоже, не могу быть уверен. Кажется, вряд ли это приведет к хорошим результатам в реальном мире. Вот пример базовой метрики шрифта подхода:

height := aPopupMenu.items.count * (abs(font.height) + 6) + 34; 

Вы можете принять во внимание скрытые элементов, и для одной версии окон с одной настройкой режима темы в действительности, вы можете получить близко, как это, но не абсолютно верно.

Подход B: Пусть для Windows это сделать:

Попробуйте пройти в TPM_BOTTOMALIGN, чтобы в конечном итоге достичь Win32 API вызова TrackPopupMenu.

До сих пор я думаю, что могу это сделать, если я изменю меню VCL menus.pas. Я использую Delphi 2007 в этом проекте. Однако я не так рад этой идее.

Вот вид кода я пытаюсь:

procedure TMyForm.ButtonClick(Sender: TObject); 
var 
    pt:TPoint; 
    popupMenuHeightEstimate:Integer; 
begin 
    // alas, how to do this accurately, what with themes, and the OnMeasureItem event 
    // changing things at runtime. 
     popupMenuHeightEstimate := PopupMenuHeight(BookingsPopupMenu); 

     pt.X := 0; 
     pt.Y := -1*popupMenuHeightEstimate; 
     pt := aButton.ClientToScreen(pt); // do the math for me. 
     aPopupMenu.popup(pt.X, pt.Y); 

end; 

В качестве альтернативы я хотел бы сделать это:

pt.X := 0; 
    pt.Y := 0; 
    pt := aButton.ClientToScreen(pt); // do the math for me. 
    aPopupMenu.popupEx(pt.X, pt.Y, TPM_BOTTOMALIGN); 

Конечно, popupEx не существует в VCL. Ни в коем случае нельзя передавать более флаги до TrackPopupMenu, чем те, которые добавили в VCL, вероятно, в 1995 году, в версии 1.0.

Примечание: Я считаю, что проблема оценки высоты перед отображением меню невозможна, поэтому мы должны решить проблему с помощью TrackPopupMenu, не оценивая высоту.

Update: Вызов TrackPopupMenu напрямую не работает, потому что остальные шаги в методе VCL TPopupMenu.Popup(x,y) необходимо вызвать для моего приложения, чтобы нарисовать его меню и он выглядит корректно, однако, невозможно вызвать их без зла обман, потому что они частные методы. Изменение VCL - адское предложение, и я тоже не хочу это развлекать.

Answer 1

Немного взломанный, но он может решить проблему.

Объявите класс перехватчика для TPopupMenu переопределяя Popup:

type 
    TPopupMenu = class(Vcl.Menus.TPopupMenu) 
    public 
    procedure Popup(X, Y: Integer); override; 
    end; 

procedure TPopupMenu.Popup(X, Y: Integer); 
const 
    Flags: array[Boolean, TPopupAlignment] of Word = 
    ((TPM_LEFTALIGN, TPM_RIGHTALIGN, TPM_CENTERALIGN), 
    (TPM_RIGHTALIGN, TPM_LEFTALIGN, TPM_CENTERALIGN)); 
    Buttons: array[TTrackButton] of Word = (TPM_RIGHTBUTTON, TPM_LEFTBUTTON); 
var 
    AFlags: Integer; 
begin 
    PostMessage(PopupList.Window, WM_CANCELMODE, 0, 0); 
    inherited; 
    AFlags := Flags[UseRightToLeftAlignment, Alignment] or 
    Buttons[TrackButton] or 
    TPM_BOTTOMALIGN or 
    (Byte(MenuAnimation) shl 10); 
    TrackPopupMenu(Items.Handle, AFlags, X, Y, 0 { reserved }, PopupList.Window, nil); 
end; 

Хитрость заключается в том, чтобы опубликовать сообщение об отмене в окно меню, которое отменяет унаследованный TrackPopupMenu вызов.

Answer 2

Я не могу дублировать вашу проблему с помощью TrackPopupMenu. С простым тестом здесь с D2007, подписи, изображения, подменю элементов, похоже, выглядят и работают правильно.

В любом случае, приведенный ниже пример устанавливает крючок CBT непосредственно перед тем, как вызывается меню. Крюк получает окно, связанное с меню, чтобы подклассифицировать его.

Если вы не хотите, чтобы во всплывающем меню можно было мигать во время напряженных условий, вместо крючка вы можете использовать класс PopupList для обработки WM_ENTERIDLE, чтобы попасть в окно меню.

type 
    TForm1 = class(TForm) 
    Button1: TButton; 
    PopupMenu1: TPopupMenu; 
    ... 
    procedure PopupMenu1Popup(Sender: TObject); 
    private 
    ... 
    end; 

    ... 

implementation 

{$R *.dfm} 

var 
    SaveWndProc: Pointer; 
    CBTHook: HHOOK; 
    ControlWnd: HWND; 
    PopupToMove: HMENU; 

function MenuWndProc(Window: HWND; Message, WParam: Longint; 
    LParam: Longint): Longint; stdcall; 
const 
    MN_GETHMENU = $01E1; // not defined in D2007 
var 
    R: TRect; 
begin 
    Result := CallWindowProc(SaveWndProc, Window, Message, WParam, LParam); 

    if (Message = WM_WINDOWPOSCHANGING) and 
     // sanity check - does the window hold our popup? 
     (HMENU(SendMessage(Window, MN_GETHMENU, 0, 0)) = PopupToMove) then begin 

    if PWindowPos(LParam).cy > 0 then begin 
     GetWindowRect(ControlWnd, R); 
     PWindowPos(LParam).x := R.Left; 
     PWindowPos(LParam).y := R.Top - PWindowPos(LParam).cy; 
     PWindowPos(LParam).flags := PWindowPos(LParam).flags and not SWP_NOMOVE; 
    end else 
     PWindowPos(LParam).flags := PWindowPos(LParam).flags or SWP_NOMOVE; 
    end; 
end; 

function CBTProc(nCode: Integer; WParam: WPARAM; LParam: LPARAM): LRESULT; stdcall; 
const 
    MENUWNDCLASS = '#32768'; 
var 
    ClassName: array[0..6] of Char; 
begin 
    Result:= CallNextHookEx(CBTHook, nCode, WParam, LParam); 

    // first window to be created that of a menu class should be our window since 
    // we already *popped* our menu 
    if (nCode = HCBT_CREATEWND) and 
     Bool(GetClassName(WParam, @ClassName, SizeOf(ClassName))) and 
     (ClassName = MENUWNDCLASS) then begin 
    SaveWndProc := Pointer(GetWindowLong(WParam, GWL_WNDPROC)); 
    SetWindowLong(WParam, GWL_WNDPROC, Longint(@MenuWndProc)); 
    // don't need the hook anymore... 
    UnhookWindowsHookEx(CBTHook);  
    end; 
end; 


procedure TForm1.PopupMenu1Popup(Sender: TObject); 
begin 
    ControlWnd := Button1.Handle;   // we'll aling the popup to this control 
    PopupToMove := TPopupMenu(Sender).Handle; // for sanity check above 
    CBTHook := SetWindowsHookEx(WH_CBT, CBTProc, 0, GetCurrentThreadId); // hook.. 
end;