Delphi 西雅图运行时 DPI 更改后如何处理菜单缩放

Question

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

菜单绘图已基本损坏，因为它依赖于 Screen.MenuFont，这是 系统范围的指标，并非特定于显示器。因此，虽然表单本身可以相对简单地适当缩放，但显示在其上的菜单只有在缩放恰好与加载到 Screen 对象的任何指标相匹配时才能正常工作。

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

真正实现此功能的唯一方法是修复 VCL。等待 Embarcadero 充实多 DPI 并不是一个真正的选择。

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

解决此限制的正确方法是什么，而不必完全重写所涉及的 classes？

我的第一个倾向是使用绕道来跟踪菜单弹出窗口并在用于设置菜单时覆盖 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，但我不想那样做。

Answer 2

Embarcadero 修复了 Delphi 10.2.3 Tokyo 中（弹出）菜单的许多错误，但 TPopupMenu 仍然不正确。我已经更新了上面的代码以在最新的 Delphi 版本中正常工作。

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.Controls, Vcl.Forms, Vcl.Menus, SysUtils,
  DDetours;

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

type
  TMenuItemHelper = class helper for TMenuItem
  public
    function GetDevicePPIproc: Pointer;
  end;

var
  TrampolineMenuCreate: procedure(const Self: TMenuClass; AOwner: TComponent) = nil;
  TrampolineMenuItemGetDevicePPI: function(const Self: TMenuItemClass): Integer;

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

function GetDevicePPIHooked(const Self: TMenuItemClass): Integer;
var
  DC: HDC;
  LParent: TMenu;
  LPlacement: TWindowPlacement;
  LMonitor: TMonitor;
  LForm: TCustomForm;
begin
  LParent := Self.GetParentMenu;

  if (LParent <> nil) and (LParent.Owner is TWinControl) and CheckWin32Version(6,3) then
  begin
    LForm := GetParentForm(TControl(LParent.Owner));

    LPlacement.length := SizeOf(TWindowPlacement);
    if (TWinControl(LForm).Handle > 0) and GetWindowPlacement(TWinControl(LForm).Handle, LPlacement) then
      LMonitor := Screen.MonitorFromPoint(LPlacement.rcNormalPosition.CenterPoint)
    else
      LMonitor := Screen.MonitorFromWindow(Application.Handle);
    if LMonitor <> nil then
      Result := LMonitor.PixelsPerInch
    else
      Result := Screen.PixelsPerInch;
  end
  else
  begin
    DC := GetDC(0);
    Result := GetDeviceCaps(DC, LOGPIXELSY);
    ReleaseDC(0, DC);
  end;
end;

{ TMenuItemHelper }

function TMenuItemHelper.GetDevicePPIproc: Pointer;
begin
  Result := @TMenuItem.GetDevicePPI;
end;

initialization

  TrampolineMenuCreate := InterceptCreate(@TMenuClass.Create, @MenuCreateHooked);
  TrampolineMenuItemGetDevicePPI := InterceptCreate(TMenuItemClass.GetDevicePPIproc, @GetDevicePPIHooked);

finalization

  InterceptRemove(@TrampolineMenuCreate);
  InterceptRemove(@TrampolineMenuItemGetDevicePPI);

end.

Delphi 西雅图运行时 DPI 更改后如何处理菜单缩放

How to handle menu scaling after runtime DPI change in Delphi Seattle

delphi

vcl

multiple-monitors

dpi