9

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

在此处输入图像描述

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;

您可以考虑隐藏的项目，并且对于具有单一主题模式设置的单一版本的窗口，您可能会像那样接近，但并不完全正确。

方法 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);

当然，VCL 中没有 popupEx。也没有任何方法可以传递TrackPopupMenu比 VCL 家伙可能在 1995 年在 1.0 版中添加的标志更多的标志。

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

更新：TrackPopupMenu直接调用不起作用，因为 VCL 方法TPopupMenu.Popup(x,y) 中的其余步骤对于调用我的应用程序以绘制其菜单并使其看起来正确是必需的，但是如果没有邪恶的技巧就不可能调用它们，因为它们是私有方法. 修改 VCL 是一个地狱般的提议，我也不希望接受它。

4

2 回答 2

6

有点hacky，但它可能会解决它。

为覆盖 Popup 的 TPopupMenu 声明一个拦截器类：

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 调用的菜单窗口。

于 2013-05-31T15:56:45.253 回答
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;
于 2013-06-01T13:30:11.893 回答