Cómo manejar la escala del menú después del cambio de DPI en tiempo de ejecución en Delphi Seattle

vcl multiple-monitors

Question

Cuando se agregó el soporte para el cambio de DPI en tiempo de ejecución a la clase de formularios, no se prestó atención a los elementos básicos de la IU, como los menús.

El dibujo del menú se rompe fundamentalmente porque se basa en Screen.MenuFont, que es una métrica de todo el sistema , no específica de los monitores. Por lo tanto, si bien el formulario en sí mismo se puede escalar de manera relativamente simple, los menús que se muestran sobre él solo funcionan correctamente SI esa escala coincide con las métricas que se cargaron en el objeto Pantalla.

Este es un problema para la barra de menú principal, sus menús emergentes y todos los menús emergentes en el formulario. Ninguna de estas escalas si el formulario se mueve a un monitor con un DPI diferente a las métricas del sistema.

La única manera de hacer que este trabajo funcione realmente es arreglar el VCL. Esperar a que Embarcadero complete el multi-DPI no es realmente una opción.

En cuanto al código VCL, el problema básico es que la propiedad Screen.MenuFont está asignada a un lienzo de menú en lugar de seleccionar una fuente adecuada para el monitor en el que aparecerá el menú. Las clases afectadas se pueden encontrar simplemente buscando Screen.MenuFont en la fuente de VCL.

¿Cuál es la forma correcta de evitar esta limitación, sin tener que volver a escribir completamente las clases involucradas?

Mi primera inclinación es usar un desvío para realizar un seguimiento de las ventanas emergentes del menú y anular la propiedad Screen.MenuFont cuando se usa para configurar un menú. Eso parece demasiado de un hack.

Answer 1

Aquí hay una solución que está funcionando por ahora. Al usar Delphi Detours Library , al agregar esta unidad a la lista de usos de dpr (tuve que colocarla cerca de la parte superior de mi lista antes que a otras formas), se aplica el tamaño de fuente correcto al lienzo del menú, según la forma que contiene Elementos del menú en cualquier menú emergente. Esta solución ignora deliberadamente los menús de nivel superior (barras del menú principal) porque el VCL no trata adecuadamente los elementos medidos por el propietario allí.

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.

Uno podría fácilmente parchear Vcl.Menus, pero no quería hacer eso.

Answer 2

Embarcadero corrigió muchos errores con los menús (emergentes) en Delphi 10.2.3 Tokyo, pero el TPopupMenu aún no es correcto. He actualizado el código anterior para que funcione correctamente en la última versión de 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.