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

Posted 2023-02-23

【中文标题】Delphi Seattle 中运行时 DPI 更改后如何处理菜单缩放

【英文标题】：How to handle menu scaling after runtime DPI change in Delphi Seattle

【发布时间】：2016-01-06 07:54:57

【问题描述】：

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

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

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

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

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

在不必完全重新编写所涉及的类的情况下，解决此限制的正确方法是什么？

我的第一个倾向是绕道来跟踪菜单弹出窗口，并在用于设置菜单时覆盖 Screen.MenuFont 属性。这似乎太过分了。

【问题讨论】：

你确定是VCL吗？记事本做对了吗？

记事本不是一个支持高 dpi 的应用程序，所以我无法在那里进行测试。我确信它是 VCL，因为它正在处理自己的菜单绘制，并且我通过重写一些代码进行了实验。问题并不难，真的——当一个弹出菜单为默认的 tmenuitem 测量和绘图设置画布时，它会将 Screen.MenuFont 字体分配给画布，它使用的是来自 Windows 的（不推荐使用的，真的）系统指标，而不是监控特定指标。

你看我不认为它是 VCL，因为即使使用系统绘制的菜单，我的 Delphi 应用程序也会发生同样的情况。您可以通过不使用字形强制系统绘制菜单来轻松检查。

Screen.MenuFont 出于所有意图和目的，是一个不推荐使用的属性，不应在高 dpi 应用程序中使用。

关于非客户区，这是documented：请注意，每个显示器的非客户区-DPI感知应用程序不会被Windows缩放，并且会按比例缩小在高 DPI 显示器上。

【参考方案1】：

这是目前有效的一种解决方案。使用Delphi Detours Library，将此单元添加到 dpr 使用列表（我必须在其他表单之前将其放在列表顶部附近）会根据包含的表单将正确的字体大小应用于菜单画布任何弹出菜单中的菜单项。此解决方案故意忽略***菜单（主菜单栏），因为 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，但我不想这样做。

【讨论】：

系统绘制的菜单会发生什么？它们是否正确缩放？如果是这样，那么除了让系统完成工作之外，做任何事情都是愚蠢的。

不，它们没有正确绘制。我不知道原因；我认为这与半生不熟的 Windows 功能有关。 “让系统来做”是我的偏好，但 192 dpi 显示器上的 96 dpi 菜单无法使用。这就是为什么我在上面明确将 OwnerDraw 设置为 True。

您确定在测试中使用系统绘制的菜单吗？不需要有字形来使 VCL 使用系统绘制的菜单。我的 VCL 版本可以使用字形制作系统绘制菜单，但 Emba 不能。

是的，绝对确定。我的测试甚至没有使用菜单上的图像列表。我需要它来处理由于图像列表而未设置为自绘或自绘的菜单。无论 VCL 或系统是否绘制它们，都会出现相同的未缩放菜单。这并不奇怪，真的。即使是 Windows 自己的对话框也并不总是在应该缩放的时候进行缩放。无论如何，我测试了这两种菜单。

添加指向RSP-12580 VCL Menus ignore per-monitor DPI scaling的链接以供交叉引用。

【参考方案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.

【讨论】：

我刚刚找到您的答案并尝试过。我看不出使用这个补丁和不使用它的弹出菜单有什么区别。这究竟应该解决什么问题？如果没有 96 dpi 和 144 dpi，我的弹出菜单看起来还不错。 （德尔福 10.2.3）