当为表单类添加支持运行时DPI切换的功能时，没有考虑到基本UI元素，例如菜单。
菜单绘制基本上是有问题的，因为它依赖于Screen.MenuFont，这是一种系统范围的指标，而不是特定于监视器的。 因此，虽然表单本身可以相对简单地正确缩放，但在其上显示的菜单仅在该缩放恰好与加载到Screen对象中的任何度量匹配时才能正常工作。
这是主菜单栏、其弹出菜单以及表单上的所有弹出菜单的问题。 如果将表单移动到具有与系统度量不同的DPI的监视器上，则所有这些内容都不会缩放。
真正使这个工作的方法是修复VCL。 等待Embarcadero完善多DPI不是一个真正的选择。
查看VCL代码，基本问题是将Screen.MenuFont属性分配给菜单画布，而不是选择适合菜单所在监视器的字体。 可以通过在VCL源代码中搜索Screen.MenuFont来找到受影响的类。
如何正确解决此限制，而无需完全重写涉及的类？
我首先的想法是使用detour跟踪菜单弹出窗口并在设置菜单时覆盖Screen.MenuFont属性。 这似乎太过于hack了。
目前有一个可行的解决方案。使用Delphi Detours Library，将此单元添加到dpr uses列表中（我必须将它放在其他表单之前），可以根据包含任何弹出菜单中菜单项的窗体应用正确的字体大小到菜单画布中。此解决方案有意忽略顶级菜单（主菜单栏），因为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，但我不想这么做。
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.