How do you line up a TPopupMenu so that it accurately positions itself above a button?

Question

I want a popup menu above a button:

Delphi wraps the Win32 menu system in a way that seems to preclude every mode or flag that the underlying Win32 API provides that was not in the VCL author's brain on that day. One such example appears to be the TPM_BOTTOMALIGN which can be passed into TrackPopupMenu but, the Delphi wrapper appears to render this not only impossible in the stock VCL, but by injudicious use of private and protected methods, is impossible (at least seems to me to be impossible) to do either accurately at runtime, or by overrides. The VCL component TPopupMenu is not very well designed either, as it should have had a virtual method called PrepareForTrackPopupMenu that did everything other than the call to TrackPopupMenu or TrackPopupMenuEx, and then allow someone to override a method that actually invokes that Win32 method. But that's too late now. Maybe Delphi XE5 will have this basic coverage of the Win32 API done right.

Approaches I have tried:

Approach A: Use METRICS or Fonts:

Accurately determine height of a popup menu so I can subtract the Y value before calling popupmenu.Popup(x,y). Results: Would have to handle all variants of Windows theming, and make assumptions that I seem unable to be sure about. Seems unlikely to result in good results in the real world. Here's an example of a basic font metrics approach:

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

You can take into account hidden items, and for a single version of windows with a single theme mode setting in effect, you might get close like that, but not exactly right.

Approach B: Let Windows Do It:

Try to pass in TPM_BOTTOMALIGN to eventually reach Win32 API call TrackPopupMenu.

So far, i think I can do it, if I modify the VCL menus.pas.. I am using Delphi 2007 in this project. I am not all that happy about that idea though.

Here is the kind of code I am trying:

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;

Alternatively I wanted to do this:

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

Of course, popupEx is not there in the VCL. Nor any way to pass in more flags to TrackPopupMenu than those that the VCL guys added probably in 1995, in version 1.0.

Note: I believe the problem of estimating the height before showing the menu is impossible, thus we should be actually having the problem solved by TrackPopupMenu not by estimating the height.

Update: Calling TrackPopupMenu directly does not work, because the rest of the steps in the VCL method TPopupMenu.Popup(x,y) are necessary to invoke for my application to paint its menu and have it look correct, however it is impossible to invoke them without evil trickery because they are private methods. Modifying the VCL is a hellish proposition and I don't wish to entertain that either.

Answer 1

A little bit hacky, but it might solve it.

Declare an interceptor class for TPopupMenu overriding 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;

The trick is to post a cancel message to the menu window which cancels the inherited TrackPopupMenu call.

Answer 2

I cannot duplicate your issue with TrackPopupMenu. With a simple test here with D2007, items' captions, images, submenus seem to look and work correctly.

Anyway, the below example installs a CBT hook just before the menu is popped. The hook retrieves the window associated with the menu to be able to subclass it.

If you don't care a possible flashing of the popup menu under stressed conditions, instead of a hook, you can use the PopupList class to handle WM_ENTERIDLE to get to the menu's window.

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;