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

Question

When support for runtime DPI switching was added to the forms class, no consideration was given to basic UI elements like menus.
Menu drawing is fundamentally broken because it relies on Screen.MenuFont, which is a system wide metric, not specific to monitors. So while the form itself can be properly scaled relatively simply, the menus that display over it only work correctly IF that scaling happens to match whatever metrics were loaded into the Screen object.
This is a problem for the main menu bar, its popup menus, and all popup menus on the form. None of these scale if the form is moved to a monitor with a different DPI than the system metrics.
The only way to really make this work is to fix the VCL. Waiting for Embarcadero to flesh out multi-DPI is not really an option.
Looking at the VCL code, the basic issue is that the Screen.MenuFont property is assigned to a menu canvas rather than selecting a font appropriate for the monitor on which the menu will appear. Affected classes can be found simply by searching for Screen.MenuFont in the VCL source.
What is the correct way to work around this limitation, without having to completely re-write the classes involved?
My first inclination is to use a detour to keep track of menu popups and override the Screen.MenuFont property when it is being used to set up a menu. That seems like too much of a hack.

Answer 1

Here is one solution that is working for now. Using the Delphi Detours Library, adding this unit to the dpr uses list (I had to put it near the top of my list before other forms) causes the correct font size to be applied to the menu canvas, based on the form that holds the menu items in any popup menu. This solution deliberately ignores toplevel menues (main menu bars) because the VCL doesn't properly deal with owner measured items there.
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.
One could just as easily patch Vcl.Menus, but I did not want to do that.

Answer 2

Embarcadero fixed a lot of bugs with (popup)menus in Delphi 10.2.3 Tokyo, but the TPopupMenu is still not correct. I've updated the code above to work correct in the latest Delphi version.
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.