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

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

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

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

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

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

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

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

ОТВЕТЫ

Ответ 1

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