delphi - Delphi Seattle 中运行时 DPI 更改后如何处理菜单缩放

Question

当表单类添加对运行时 DPI 切换的支持时，没有考虑菜单等基本 UI 元素。

菜单绘制从根本上被破坏，因为它依赖于 Screen.MenuFont，这是一个系统范围的指标，而不是特定于显示器。因此，虽然表单本身可以相对简单地正确缩放，但只有当缩放恰好与加载到 Screen 对象中的任何指标相匹配时，其上显示的菜单才能正常工作。

这是主菜单栏、其弹出菜单以及窗体上的所有弹出菜单的问题。如果将表单移动到具有与系统指标不同的 DPI 的监视器，则这些都不会缩放。

真正使这项工作有效的唯一方法是修复 VCL。等待 Embarcadero 充实多 DPI 并不是一个真正的选择。

查看 VCL 代码，基本问题是 Screen.MenuFont 属性被分配给菜单 Canvas ，而不是选择适合显示菜单的监视器的字体。只需在 VCL 源代码中搜索 Screen.MenuFont 即可找到受影响的类。

无需完全重写所涉及的类，解决此限制的正确方法是什么？

我的第一个倾向是使用迂回方式来跟踪菜单弹出窗口，并在使用 Screen.MenuFont 属性设置菜单时覆盖该属性。这看起来太过分了。

Answer 1

这是一种目前有效的解决方案。使用Delphi Detours Library ，将此单元添加到 dpr 使用列表(我必须在其他表单之前将其放在列表顶部附近)会导致根据在任何弹出窗口中保存菜单项的表单，将正确的字体大小应用于菜单 Canvas 菜单。该解决方案故意忽略顶级菜单(主菜单栏)，因为 VCL 无法正确处理那里的所有者测量的项目。

unit slMenuDPIFix;

// add this unit to the main application dpr file BEFORE ANY FORMS in the uses list.

interface

implementation

uses
  Winapi.Windows, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Menus, slScaleUtils, Math,
  DDetours;

type
  TMenuClass = class(TMenu);
  TMenuItemClass = class(TMenuItem);

var
  TrampolineMenuCreate: procedure(const Self: TMenuClass; AOwner: TComponent) = nil;
  TrampolineMenuItemAdvancedDrawItem: procedure(const Self: TMenuItemClass; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState; TopLevel: Boolean) = nil;
  TrampolineMenuItemMeasureItem: procedure(const Self: TMenuItemClass; ACanvas: TCanvas; var Width, Height: Integer) = nil;

function GetPopupDPI(const MenuItem: TMenuItemClass): Integer;
var
  pm: TMenu;
  pcf: TCustomForm;
begin
  Result := Screen.PixelsPerInch;
  pm := MenuItem.GetParentMenu;
  if Assigned(pm) and (pm.Owner is TControl) then
    pcf := GetParentForm(TControl(pm.Owner))
  else
    pcf := nil;
  if Assigned(pcf) and (pcf is TForm) then
    Result := TForm(pcf).PixelsPerInch;
end;

procedure MenuCreateHooked(const Self: TMenuClass; AOwner: TComponent);
begin
  TrampolineMenuCreate(Self, AOwner);
  Self.OwnerDraw := True;     // force always ownerdraw.
end;

procedure MenuItemAdvancedDrawItemHooked(const Self: TMenuItemClass; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState; TopLevel: Boolean);
begin
  if (not TopLevel) then
  begin
    ACanvas.Font.Height := MulDiv(ACanvas.Font.Height, GetPopupDPI(Self), Screen.PixelsPerInch);
  end;
  TrampolineMenuItemAdvancedDrawItem(Self, ACanvas, ARect, State, TopLevel);
end;

procedure MenuItemMeasureItemHooked(const Self: TMenuItemClass; ACanvas: TCanvas; var Width, Height: Integer);
var
  lHeight: Integer;
  pdpi: Integer;
begin
  pdpi := GetPopupDPI(Self);
  if (Self.Caption <> cLineCaption) and (pdpi <> Screen.PixelsPerInch) then
  begin
    ACanvas.Font.Height := MulDiv(ACanvas.Font.Height, pdpi, Screen.PixelsPerInch);
    lHeight := ACanvas.TextHeight('|') + MulDiv(6, pdpi, Screen.PixelsPerInch);
  end else
    lHeight := 0;

  TrampolineMenuItemMeasureItem(Self, ACanvas, Width, Height);

  if lHeight > 0 then
    Height := Max(Height, lHeight);
end;

initialization

  TrampolineMenuCreate := InterceptCreate(@TMenuClass.Create, @MenuCreateHooked);
  TrampolineMenuItemAdvancedDrawItem := InterceptCreate(@TMenuItemClass.AdvancedDrawItem, @MenuItemAdvancedDrawItemHooked);
  TrampolineMenuItemMeasureItem := InterceptCreate(@TMenuItemClass.MeasureItem, @MenuItemMeasureItemHooked);

finalization

  InterceptRemove(@TrampolineMenuCreate);
  InterceptRemove(@TrampolineMenuItemAdvancedDrawItem);
  InterceptRemove(@TrampolineMenuItemMeasureItem);

end.

人们可以轻松地修补 Vcl.Menus，但我不想这样做。