Как обрабатывать масштабирование меню после изменения DPI во время выполнения в Delphi Seattle

Question

Когда в класс форм была добавлена ​​поддержка переключения DPI во время выполнения, основные элементы пользовательского интерфейса, такие как меню, не рассматривались.

Рисование меню в основном нарушено, поскольку оно основано на Screen.MenuFont, который является метрикой всей системы, а не только для мониторов. Таким образом, хотя саму форму можно относительно легко масштабировать относительно просто, меню, отображаемые над ней, работают правильно только в том случае, если масштабирование соответствует тем метрикам, которые были загружены в объект Screen.

Это проблема для главного меню, его всплывающих меню и всех всплывающих меню в форме. Ни один из них не масштабируется, если форма перемещается на монитор с DPI, отличным от системных показателей.

Единственный способ действительно сделать эту работу - это исправить VCL. Ожидание, пока Embarcadero расширит мульти-DPI, на самом деле не вариант.

Глядя на код VCL, основная проблема заключается в том, что свойство Screen.MenuFont назначается холсту меню, а не выбору шрифта, подходящего для монитора, на котором будет отображаться меню. Затронутые классы можно найти, просто выполнив поиск Screen.MenuFont в источнике VCL.

Как правильно обойти это ограничение, без необходимости полностью переписывать участвующие классы?

Мое первое желание состоит в том, чтобы использовать обходной путь для отслеживания всплывающих окон меню и переопределять свойство Screen.MenuFont, когда оно используется для настройки меню. Это похоже на слишком много взлома.

Answer 1

Вот одно решение, которое работает на данный момент. Используя библиотеку Delphi Detours, добавление этого модуля в список использований 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, 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, но я не хотел этого делать.

Answer 2

Embarcadero исправил множество ошибок с (всплывающими) меню в Delphi 10.2.3 Токио, но 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.