当支持运行时DPI切换被添加到窗体类时,没有考虑到诸如菜单之类的基本UI元素.
菜单绘图基本上被打破,因为它依赖于Screen.MenuFont,这是一个系统范围的度量,不是特定于监视器的.因此,当表单本身可以相对简单地适当地缩放时,显示在其上的菜单只能正常工作,如果缩放恰好匹配任何加载到Screen对象中的指标.
这是主菜单栏,其弹出菜单和窗体上的所有弹出菜单的问题.如果表单被移动到具有与系统指标不同的DPI的监视器,则这些比例都不会变化.
真正做这个工作的唯一方法是修复VCL.等待Embarcadero出血多DPI并不是一个选择.
看一下VCL代码,基本的问题是Screen.MenuFont属性被分配到一个菜单画布,而不是选择一个与显示器相对应的字体.受影响的类可以通过在VCL源中搜索Screen.MenuFont来简单地找到.
我的第一个倾向是使用绕行来跟踪菜单弹出窗口,并在用于设置菜单时重写Screen.MenuFont属性.这似乎是一个黑客的太多.
解决方法
这是现在正在开发的一个解决方案.使用
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,Screen.PixelsPerInch);
end else
lHeight := 0;
TrampolineMenuItemMeasureItem(Self,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一样轻松的修补,但是我不想这样做.