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

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.

Aid

Are you sure it's the VCL? Does Notepad get this right? – Cheops

Notepad is not a high-dpi aware app so I can't test it there. I am sure it's the VCL because it is handling its own drawing of the menus, and I experimented by rewriting some of the code. The problem is not that hard, really -- when a popupmenu sets up the canvas for default tmenuitem measurements and drawing, it assigns the Screen.MenuFont font to the canvas, which is using the (deprecated, really) system metrics from Windows instead of monitor-specific metrics. – Aid

You see I don't think it is the VCL because the same happens in my Delphi app even with system drawn menus. You can check easily by forcing system drawn menus by using no glyphs. – Cheops

And the non-client area is also not scaled per monitor. I think MS has done half a job here. – Cheops

@DavidHeffernan I see what you are saying, but the VCL can easily fix this by selecting the correct font in, for example, TPopupList.WndProc. Instead of assigning a system-wide deprecated metric to the canvas it could get the correct one for the monitor. I guess what I am looking for is the correct way to do this myself. – Aid

Yes, but even if MS "finishes the job" the VCL will not do it right because it is not pulling the correct font when it sets up the canvas. – Aid

Screen.MenuFont is, for all intents and purposes, a deprecated property that should not be used in a high-dpi application. – Aid

I personally bypass the VCL code and have the system draw the menus. And so far as I know, they don't get scaled in a per monitor way. I'm far from convinced that this tech is ready for the mainstream. I think MS apps deal with this by drawing the non-client area themselves. – Cheops

Now, for what it is worth, my app uses a bespoke version of Menus.pas to workaround various flaws in Emba code. You can do the same yourself. Copy Menus.pas. Include it in your project. Make the changes you need. That's how I suppress the bogus custom drawing code and instead use system drawn menus. – Cheops

Regarding the non-client area, this is documented: Note that the non-client area of a per monitor–DPI aware application is not scaled by Windows, and will appear proportionately smaller on a high DPI display. – Cheops

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.

Aid

What happens with system drawn menus? Are they scaled properly? If so then it would be folly to do anything but let the system do the work. – Cheops

No, they are not drawn correctly. I do not know the reason; I presume it has to do with half-baked Windows functionality. "let the system do it" would be my preference but a 96 dpi menu on a 192 dpi monitor is unusable. That is why I am explicitly setting OwnerDraw to True up there. – Aid

Are you sure you are using system drawn menus in your test? There need to be no glyphs to make the VCL use system drawn menus. My version of the VCL can do system drawn menus with glyphs, but Emba's cannot. – Cheops

Yes, absolutely sure. My tests didn't even use image lists on the menus; I needed this to work with menus that are not set as owner-drawn or owner-drawn due to image lists. The same unscaled menus happen regardless of whether or not the VCL or the system draws them. This is no surprise, really. Even Windows' own dialogs don't always scale when they should. Anyway, I tested both kinds of menus. – Aid

If it were me, I'd be finding a way to get Windows to do the work. It must be possible. Of course, the non-client area not scaling is a bit of a kicker. My current thoughts are to ignore per monitor DPI because MS have done half a job. – Cheops

The fact that NC isn't scaled is an indication of how far they are willing to go. Ignoring this isn't an option for me at this point. Too many new devices are coming with 4K displays that will also power 96 dpi outputs (laptops, etc) and I need something usable that doesn't rely on being non-dpi-aware (blurry scaling is not acceptable either). I would expect to see a popup menu fix for scaling in Windows in the future but for now this one unit gets the job done. – Aid

Besides, ownerdraw is a feature in VCL and needs to work. – Aid

Depends whether you are writing library code or application code. I personally could not care one iota about owner drawn menus because I don't use them in my app. I have to say I'd be surprised if system drawn menus couldn't scale properly in per monitor dpi. – Cheops

Well, my test could be faulty. Although I am sure I let WIndows draw it, maybe I missed something. How do you suggest I make sure? I would certainly prefer to let Windows do it. – Aid

I'll look into this and report back if I find anything useful – Cheops

Adding link to RSP-12580 VCL Menus ignore per-monitor DPI scaling for cross-reference. – Gavel

It looks like even for system drawn menus, you need to add code to scale them. Which surprises me. As for the menus that result from the code in your app, don't they look non-native? Don't they look like XP era menus? – Cheops

Hard to say what "native" looks like in Windows 10 since there are three different "native" popup menu styles out of the box (Start menu popups, File Explorer, and Edge each have a different look). But no, they do not look like XP menus. The look the same as the Internet Explorer 11 pop-up menus. – Aid

It doesn't work in 2022 in Delphi 10.3 Rio.... I added that unit and the main menu is drawn incorrectly. – Presumptuous

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.

Martsen

I just found your answer an tried it. I can't see any difference for popup menus between using this patch and not using it. What exactly is this supposed to fix? My popup menus look fine without it on 96 dpi and 144 dpi. (Delphi 10.2.3) – Worlock