LCL: High-DPI: fix font scaling and design-time scaling. Issues #32882 and #32944

git-svn-id: trunk@56962 -
This commit is contained in:
ondrej 2018-01-05 08:10:01 +00:00
parent 611c971eaf
commit d7f8f5e5f6
5 changed files with 114 additions and 134 deletions

View File

@ -1200,7 +1200,7 @@ const
PreferredDistanceMax = 250;
var
NewJITIndex: Integer;
CompLeft, CompTop, CompWidth, CompHeight: integer;
CompLeft, CompTop, CompWidth, CompHeight, NewPPI: integer;
NewComponent: TComponent;
OwnerComponent: TComponent;
JITList: TJITComponentList;
@ -1370,6 +1370,16 @@ begin
if CompTop < 0 then
CompTop := 0;
if AParent<>nil then
NewPPI := NeedParentDesignControl(AParent).PixelsPerInch
else
if (AControl is TCustomForm) then
NewPPI := TCustomForm(AControl).Monitor.PixelsPerInch
else
NewPPI := 0;
if NewPPI > 0 then
AControl.AutoAdjustLayout(lapAutoAdjustForDPI, 96, NewPPI, 0, 0);
if (AParent <> nil) or (AControl is TCustomForm) then
begin
// set parent after placing control to prevent display at (0,0)

View File

@ -1434,7 +1434,7 @@ type
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double); virtual;
procedure DoFixDesignFontPPI(const AFont: TFont; const ADesignTimePPI: Integer);
procedure DoScaleFontPPI(const AFont: TFont; const AProportion: Double);
procedure DoScaleFontPPI(const AFont: TFont; const AToPPI: Integer; const AProportion: Double);
protected
// actions
function GetActionLinkClass: TControlActionLinkClass; virtual;
@ -1564,8 +1564,7 @@ type
procedure AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy;
const AFromPPI, AToPPI, AOldFormWidth, ANewFormWidth: Integer); virtual;
procedure ShouldAutoAdjust(var AWidth, AHeight: Boolean); virtual;
procedure FixDesignFontsPPI(const ADesignTimePPI: Integer); virtual;
procedure ScaleFontsPPI(const AProportion: Double); virtual;
procedure ScaleFontsPPI(const AToPPI: Integer; const AProportion: Double); virtual;
public
constructor Create(TheOwner: TComponent);override;
destructor Destroy; override;

View File

@ -272,13 +272,14 @@ type
protected
procedure SetScaled(const AScaled: Boolean); virtual;
procedure AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy; const AFromPPI,
AToPPI, AOldFormWidth, ANewFormWidth: Integer); override;
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double); override;
procedure Loaded; override;
public
constructor Create(TheOwner: TComponent); override;
procedure AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy; const AFromPPI,
AToPPI, AOldFormWidth, ANewFormWidth: Integer); override;
public
property DesignTimePPI: Integer read FDesignTimePPI write SetDesignTimePPI default 96;
property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch stored False;

View File

@ -834,12 +834,13 @@ begin
Result := MulDiv(ASize, Screen.PixelsPerInch, Font.PixelsPerInch);
end;
procedure TControl.ScaleFontsPPI(const AProportion: Double);
procedure TControl.ScaleFontsPPI(const AToPPI: Integer;
const AProportion: Double);
begin
// Problem: all fonts have to be scaled.
// Override this function - list all custom fonts in the overriden procedure
DoScaleFontPPI(Font, AProportion);
DoScaleFontPPI(Font, AToPPI, AProportion);
end;
{------------------------------------------------------------------------------
@ -942,18 +943,6 @@ procedure TControl.ExecuteDefaultAction;
begin
end;
procedure TControl.FixDesignFontsPPI(const ADesignTimePPI: Integer);
begin
// Problem: Font.PixelsPerInch isn't saved in the LFM, therefore the
// design-time font PPI is different from the one that is loaded on target
// machine, which results in different font scaling.
// DoFixDesignFont restores the corrent design-time font PPI so that it can
// be used for LCL HighDPI scaling.
// Override this function - list all custom fonts in the overriden procedure
DoFixDesignFontPPI(Font, ADesignTimePPI);
end;
procedure TControl.ExecuteCancelAction;
begin
end;
@ -1921,13 +1910,16 @@ begin
OnShowHint(Self,HintInfo);
end;
procedure TControl.DoScaleFontPPI(const AFont: TFont;
procedure TControl.DoScaleFontPPI(const AFont: TFont; const AToPPI: Integer;
const AProportion: Double);
begin
// If AFont.PixelsPerInch is different from "Screen.PixelsPerInch" (=GetDeviceCaps(DC, LOGPIXELSX))
// then the font doesn't scale -> we have to assign a nonzero height value.
if (AFont.Height=0) and not (csDesigning in ComponentState) then
AFont.Height := MulDiv(GetFontData(AFont.Reference.Handle).Height, AFont.PixelsPerInch, Screen.PixelsPerInch);
if AToPPI>0 then
AFont.PixelsPerInch := MulDiv(AFont.PixelsPerInch, AToPPI, AFont.PixelsPerInch)
else
AFont.PixelsPerInch := Round(AFont.PixelsPerInch*AProportion);
end;
@ -3123,11 +3115,6 @@ begin
// Apply the changes
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
begin
DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.DoAutoAdjustLayout'){$ENDIF};
try
if not ParentFont or (Parent=nil) then
ScaleFontsPPI(AYProportion);
// Dimensions
AAWidth := False;
AAHeight := False;
@ -3210,13 +3197,13 @@ begin
FBaseBounds.Top:=NewBaseTop;
FBaseBounds.Right:=NewBaseLeft+NewBaseWidth;
FBaseBounds.Bottom:=NewBaseTop+NewBaseHeight;
if Parent<>nil then
begin
FBaseParentClientSize.cx:=Parent.ClientWidth;
FBaseParentClientSize.cy:=Parent.ClientHeight;
end;
SetBoundsKeepBase(NewLeft, NewTop, NewWidth, NewHeight);
finally
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.DoAutoAdjustLayout'){$ENDIF};
end;
end;
end;
@ -4169,7 +4156,15 @@ begin
if AFromPPI > 0 then lYProportion := AToPPI / AFromPPI
else lYProportion := 1.0;
DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.AutoAdjustLayout'){$ENDIF};
try
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
ScaleFontsPPI(AToPPI, lYProportion);
DoAutoAdjustLayout(lMode, lXProportion, lYProportion);
finally
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.AutoAdjustLayout'){$ENDIF};
end;
end;
// Auto-adjust the layout of controls.

View File

@ -46,11 +46,6 @@ begin
// Apply the changes
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
begin
DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TCustomForm.DoAutoAdjustLayout'){$ENDIF};
try
if not ParentFont or (Parent=nil) then
ScaleFontsPPI(AYProportion);
NewWidth := Round(Width*AXProportion);
NewHeight := Round(Height*AYProportion);
@ -58,34 +53,14 @@ begin
Constraints.AutoAdjustLayout(AXProportion, AYProportion);
SetBounds(Left, Top, NewWidth, NewHeight);
finally
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TCustomForm.DoAutoAdjustLayout'){$ENDIF};
end;
end;
end;
procedure TCustomDesignControl.Loaded;
procedure FixChildren(const AParent: TWinControl);
var
I: Integer;
begin
for I := 0 to AParent.ControlCount-1 do
begin
AParent.Controls[I].FixDesignFontsPPI(FDesignTimePPI);
if AParent.Controls[I] is TWinControl then
FixChildren(TWinControl(AParent.Controls[I]));
end;
end;
begin
inherited Loaded;
FPixelsPerInch := FDesignTimePPI;
if Application.Scaled and Scaled then
begin
FixDesignFontsPPI(FDesignTimePPI);
FixChildren(Self);
end;
end;
procedure TCustomDesignControl.SetDesignTimePPI(const ADesignTimePPI: Integer);