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

这是现在正在开发的一个解决方案.使用 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一样轻松的修补,但是我不想这样做.