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.