Question

我想要一个按钮上方的弹出菜单：

enter image description here

Delphi包装Win32菜单系统的方式似乎排除了基础Win32 API提供的当天不在VCL作者大脑中的每个模式或标志。一个这样的例子似乎是TPM_BOTTOMALIGN可以传递到TrackPopupMenu但是，Delphi包装器似乎不仅在库存VCL中使这不可能，而且通过不明智地使用私有和受保护的方法，是不可能（至少在我看来是不可能的）在运行时或通过覆盖来准确地做。 VCL组件TPopupMenu的设计也不是很好，因为它应该有一个名为PrepareForTrackPopupMenu的虚拟方法，它除了调用TrackPopupMenu或TrackPopupMenuEx之外还执行了所有操作，然后允许某人使用覆盖实际调用Win32方法的方法。但现在已经太晚了。也许Delphi XE5将完成对Win32 API的基本覆盖。

我尝试过的方法：

方法A：使用METRICS或字体：

准确确定弹出菜单的高度，以便在调用popupmenu.Popup（x，y）之前减去Y值。结果：必须处理Windows主题的所有变体，并做出我似乎无法确定的假设。似乎不太可能在现实世界中取得好成绩。以下是基本字体度量方法的示例：

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

您可以考虑隐藏的项目，对于单个主题模式设置的单个版本的Windows，您可能会接近这样，但不完全正确。

方法B：让Windows执行：

尝试传递TPM_BOTTOMALIGN以最终到达Win32 API调用TrackPopupMenu。

到目前为止，我认为我可以做到，如果我修改VCL菜单。我在这个项目中使用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);

当然，VCL中没有popupEx。也没有任何方式可以传递更多 TrackPopupMenu的旗帜，而不是VCL家伙在1995年加入的旗帜，在1.0版本中。

注意：我认为在显示菜单之前估计高度的问题是不可能的，因此我们实际上应该通过TrackPopupMenu来解决问题而不是通过估计高度来解决问题。

更新：直接调用TrackPopupMenu不起作用，因为VCL方法TPopupMenu.Popup(x,y)中的其余步骤是调用我的应用程序绘制其菜单并使其看起来正确所必需的，但它没有邪恶的诡计是不可能调用它们的，因为它们是私有的方法。修改VCL是一个地狱般的主张，我也不想接受它。

Answer 1

有点hacky，但它可以解决它。

声明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以进入菜单的窗口。 / p>

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;

你如何排列TPopupMenu，使其准确定位在按钮上方？

2 个答案: