paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-10 03:48:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

LCL: HighDPI: fix font scaling. Issue #31276

Browse Source 
git-svn-id: trunk@54210 -
This commit is contained in:
ondrej 2017-02-20 13:59:36 +00:00
parent 1b57bc9ee8
commit eb28e06e83
15 changed files with 92 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
lcl/comctrls.pp
View File

@ -159,7 +159,7 @@ type
procedure LMDrawItem(var Message: TLMDrawItems); message LM_DRAWITEM;
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean); override;
const AXProportion, AYProportion: Double; const AToDPI: Integer); override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
@ -1490,7 +1490,7 @@ type
procedure DoItemChecked(AItem: TListItem);
procedure DoSelectItem(AItem: TListItem; ASelected: Boolean); virtual;
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean); override;
const AXProportion, AYProportion: Double; const AToDPI: Integer); override;
procedure DoSetBounds(ALeft, ATop, AWidth, AHeight: integer); override;
procedure DoEndEdit(AItem: TListItem; const AValue: String); virtual;
@ -2252,7 +2252,7 @@ type
Simulate: boolean): Boolean;
procedure CNDropDownClosed(var Message: TLMessage); message CN_DROPDOWNCLOSED;
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean); override;
const AXProportion, AYProportion: Double; const AToDPI: Integer); override;
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;

13
lcl/controls.pp
View File

@ -1419,8 +1419,8 @@ type
class function GetControlClassDefaultSize: TSize; virtual;
function ColorIsStored: boolean; virtual;
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double;
const AScale0Fonts: Boolean); virtual;
const AXProportion, AYProportion: Double; const AToDPI: Integer); virtual;
class procedure DoFixDesignFontPPI(const AFont: TFont; const ADesignTimePPI: Integer);
protected
// actions
function GetActionLinkClass: TControlActionLinkClass; virtual;
@ -1536,10 +1536,12 @@ type
property ReadBounds: TRect read FReadBounds;
property BaseParentClientSize: TSize read FBaseParentClientSize;
procedure WriteLayoutDebugReport(const Prefix: string); virtual;
public
// LCL Scaling (High-DPI)
procedure AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy;
const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer;
const AScale0Fonts: Boolean); virtual;
const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer); virtual;
procedure ShouldAutoAdjust(var AWidth, AHeight: Boolean); virtual;
procedure FixDesignFontsPPI(const ADesignTimePPI: Integer); virtual;
public
constructor Create(TheOwner: TComponent);override;
destructor Destroy; override;
@ -2211,8 +2213,7 @@ type
procedure ScrollBy(DeltaX, DeltaY: Integer); virtual;
procedure WriteLayoutDebugReport(const Prefix: string); override;
procedure AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy; const AFromDPI,
AToDPI, AOldFormWidth, ANewFormWidth: Integer;
const AScale0Fonts: Boolean); override;
AToDPI, AOldFormWidth, ANewFormWidth: Integer); override;
public
constructor Create(TheOwner: TComponent);override;
constructor CreateParented(AParentWindow: HWND);

7
lcl/forms.pp
View File

@ -266,7 +266,7 @@ type
procedure SetScaled(const AScaled: Boolean); virtual;
procedure AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy; const AFromDPI,
AToDPI, AOldFormWidth, ANewFormWidth: Integer; const AScale0Fonts: Boolean); override;
AToDPI, AOldFormWidth, ANewFormWidth: Integer); override;
procedure Loaded; override;
public
constructor Create(TheOwner: TComponent); override;
@ -549,8 +549,7 @@ type
procedure CreateWnd; override;
procedure Deactivate; virtual;
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double;
const AScale0Fonts: Boolean); override;
const AXProportion, AYProportion: Double; const AToDPI: Integer); override;
procedure DoClose(var CloseAction: TCloseAction); virtual;
procedure DoCreate; virtual;
procedure DoDestroy; virtual;
@ -665,7 +664,7 @@ type
function GetMDIChildren(AIndex: Integer): TCustomForm; virtual;
function MDIChildCount: Integer; virtual;
public
procedure AutoScale(const AScale0Fonts: Boolean); // set scaled to True and AutoAdjustLayout to current monitor PPI
procedure AutoScale; // set scaled to True and AutoAdjustLayout to current monitor PPI
public
// drag and dock
procedure Dock(NewDockSite: TWinControl; ARect: TRect); override;

6
lcl/grids.pas
View File

@ -960,7 +960,7 @@ type
function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean); override;
const AXProportion, AYProportion: Double; const AToDPI: Integer); override;
procedure DoOnChangeBounds; override;
procedure DoOPDeleteColRow(IsColumn: Boolean; index: Integer);
procedure DoOPExchangeColRow(IsColumn: Boolean; index, WithIndex: Integer);
@ -6749,12 +6749,12 @@ begin
end;
procedure TCustomGrid.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean);
const AXProportion, AYProportion: Double; const AToDPI: Integer);
var
i: Integer;
C: TGridColumn;
begin
inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion, AScale0Fonts);
inherited;
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
begin

7
lcl/groupededit.pp
View File

@ -179,8 +179,7 @@ type
procedure SetTextHint(AValue: TTranslateString);
protected
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean);
override;
const AXProportion, AYProportion: Double; const AToDPI: Integer); override;
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
WithThemeSpace: Boolean); override;
function CreateBuddy: TControl; virtual;
@ -1248,9 +1247,9 @@ end;
procedure TCustomAbstractGroupedEdit.DoAutoAdjustLayout(
const AMode: TLayoutAdjustmentPolicy; const AXProportion,
AYProportion: Double; const AScale0Fonts: Boolean);
AYProportion: Double; const AToDPI: Integer);
begin
inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion, AScale0Fonts);
inherited;
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
begin

45
lcl/include/control.inc
View File

@ -896,6 +896,19 @@ 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.
DoFixDesignFontPPI(Font, ADesignTimePPI);
// override this function - list all custom fonts in the overriden procedure
end;
procedure TControl.ExecuteCancelAction;
begin
end;
@ -1472,6 +1485,22 @@ begin
if Assigned(FOnEndDrag) then FOnEndDrag(Self,Target,X,Y);
end;
{------------------------------------------------------------------------------
TControl.DoFixDesignFontPPI
------------------------------------------------------------------------------}
class procedure TControl.DoFixDesignFontPPI(const AFont: TFont;
const ADesignTimePPI: Integer);
var
H: Integer;
begin
if AFont.PixelsPerInch <> ADesignTimePPI then
begin
H := AFont.Height;
AFont.Height := MulDiv(H, AFont.PixelsPerInch, ADesignTimePPI);
AFont.PixelsPerInch := ADesignTimePPI;
end;
end;
{------------------------------------------------------------------------------
TControl.Perform
@ -2947,18 +2976,13 @@ begin
end;
procedure TControl.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean);
const AXProportion, AYProportion: Double; const AToDPI: Integer);
var
AAWidth, AAHeight: Boolean;
NewLeft, NewTop, NewWidth, NewHeight, NewRight, NewBottom, OldWidth, OldHeight: Integer;
begin
if (AScale0Fonts or (Font.Height<>0)) and (not ParentFont or (Parent=nil)) then
begin
if Font.Size<>0 then
Font.Size := Round(Font.Size*AYProportion)
else
Font.Height := Round(GetFontData(Font.Reference.Handle).Height*AYProportion);
end;
if not ParentFont or (Parent=nil) then
Font.PixelsPerInch := AToDPI;
// Apply the changes
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
@ -3960,8 +3984,7 @@ begin
end;
procedure TControl.AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy;
const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer;
const AScale0Fonts: Boolean);
const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer);
var
lXProportion, lYProportion: Double;
lMode: TLayoutAdjustmentPolicy;
@ -3985,7 +4008,7 @@ begin
if AFromDPI > 0 then lYProportion := AToDPI / AFromDPI
else lYProportion := 1.0;
DoAutoAdjustLayout(lMode, lXProportion, lYProportion, AScale0Fonts);
DoAutoAdjustLayout(lMode, lXProportion, lYProportion, AToDPI);
end;
// Auto-adjust the layout of controls.

16
lcl/include/customdesigncontrol.inc
View File

@ -21,20 +21,28 @@ begin
end;
procedure TCustomDesignControl.AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy;
const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer;
const AScale0Fonts: Boolean);
const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer);
begin
inherited AutoAdjustLayout(AMode, AFromDPI, AToDPI, AOldFormWidth,
ANewFormWidth, AScale0Fonts);
inherited;
FPixelsPerInch := AToDPI;
end;
procedure TCustomDesignControl.Loaded;
var
I: Integer;
begin
inherited Loaded;
FPixelsPerInch := FDesignTimePPI;
if Application.Scaled and Scaled then
begin
FixDesignFontsPPI(FDesignTimePPI);
for I := 0 to ComponentCount-1 do
if Components[I] is TControl then
TControl(Components[I]).FixDesignFontsPPI(FDesignTimePPI);
end;
end;
procedure TCustomDesignControl.SetDesignTimePPI(const ADesignTimePPI: Integer);

26
lcl/include/customform.inc
View File

@ -161,8 +161,7 @@ begin
if Application.Scaled and Scaled and (Monitor.PixelsPerInch<>PixelsPerInch) then
AutoAdjustLayout(lapAutoAdjustForDPI, PixelsPerInch, Monitor.PixelsPerInch,
Width, MulDiv(Width, Monitor.PixelsPerInch, PixelsPerInch),
Screen.PixelsPerInch<>Monitor.PixelsPerInch);
Width, MulDiv(Width, Monitor.PixelsPerInch, PixelsPerInch));
end;
{------------------------------------------------------------------------------
@ -504,7 +503,7 @@ begin
MoveToDefaultPosition;
end;
procedure TCustomForm.AutoScale(const AScale0Fonts: Boolean);
procedure TCustomForm.AutoScale;
begin
if not Scaled then
begin
@ -515,7 +514,7 @@ begin
if PixelsPerInch<>Monitor.PixelsPerInch then
AutoAdjustLayout(lapAutoAdjustForDPI, PixelsPerInch, Monitor.PixelsPerInch,
MulDiv(Width, Monitor.PixelsPerInch, PixelsPerInch),
MulDiv(Height, Monitor.PixelsPerInch, PixelsPerInch), AScale0Fonts);
MulDiv(Height, Monitor.PixelsPerInch, PixelsPerInch));
end;
{------------------------------------------------------------------------------
@ -1569,23 +1568,18 @@ begin
end;
procedure TCustomForm.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean);
const AXProportion, AYProportion: Double; const AToDPI: Integer);
var
NewWidth, NewHeight, OldWidth, OldHeight: Integer;
begin
if Assigned(Parent) then
begin
inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion, AScale0Fonts);
inherited;
Exit;
end;
if (AScale0Fonts or (Font.Height<>0)) and (not ParentFont or (Parent=nil)) then
begin
if Font.Size<>0 then
Font.Size := Round(Font.Size*AYProportion)
else
Font.Height := Round(GetFontData(Font.Reference.Handle).Height*AYProportion);
end;
if not ParentFont or (Parent=nil) then
Font.PixelsPerInch := AToDPI;
// Apply the changes
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
@ -1915,7 +1909,7 @@ begin
inherited SetScaled(AScaled);
if not OldScaled and Scaled
and (ComponentState * [csDesigning, csLoading] = []) then // not in designtime and not when loading
AutoScale(Screen.PixelsPerInch<>Monitor.PixelsPerInch);
AutoScale;
end;
{------------------------------------------------------------------------------
@ -2301,7 +2295,7 @@ begin
NewDpi := hi(Msg.wParam);
if Scaled and (NewDpi<>PixelsPerInch) then
AutoAdjustLayout(lapAutoAdjustForDPI, PixelsPerInch, NewDpi,
Width, MulDiv(Width, NewDpi, PixelsPerInch), True);
Width, MulDiv(Width, NewDpi, PixelsPerInch));
end;
end;
@ -2320,7 +2314,7 @@ procedure TCustomForm.Show;
begin
if Scaled and (Monitor.PixelsPerInch<>PixelsPerInch) then
AutoAdjustLayout(lapAutoAdjustForDPI, PixelsPerInch, Monitor.PixelsPerInch,
Width, MulDiv(Width, Monitor.PixelsPerInch, PixelsPerInch), True);
Width, MulDiv(Width, Monitor.PixelsPerInch, PixelsPerInch));
Visible := True;
BringToFront;

2
lcl/include/customframe.inc
View File

@ -133,7 +133,7 @@ begin
ParentForm := GetParentForm(Self);
if (ParentForm<>nil) and ParentForm.Scaled
and (ParentForm.PixelsPerInch<>PixelsPerInch) then
AutoAdjustLayout(lapAutoAdjustForDPI, PixelsPerInch, ParentForm.PixelsPerInch, 0, 0, False);
AutoAdjustLayout(lapAutoAdjustForDPI, PixelsPerInch, ParentForm.PixelsPerInch, 0, 0);
end;
end;

7
lcl/include/customlistbox.inc
View File

@ -469,10 +469,11 @@ begin
end;
end;
procedure TCustomListBox.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean);
procedure TCustomListBox.DoAutoAdjustLayout(
const AMode: TLayoutAdjustmentPolicy; const AXProportion,
AYProportion: Double; const AToDPI: Integer);
begin
inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion, AScale0Fonts);
inherited;
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
begin

7
lcl/include/customlistview.inc
View File

@ -611,13 +611,14 @@ begin
FOnSelectItem(Self, AItem, ASelected);
end;
procedure TCustomListView.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean);
procedure TCustomListView.DoAutoAdjustLayout(
const AMode: TLayoutAdjustmentPolicy; const AXProportion,
AYProportion: Double; const AToDPI: Integer);
var
i: Integer;
C: TListColumn;
begin
inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion, AScale0Fonts);
inherited;
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
begin

4
lcl/include/statusbar.inc
View File

@ -148,11 +148,11 @@ begin
end;
procedure TStatusBar.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean);
const AXProportion, AYProportion: Double; const AToDPI: Integer);
var
I: Integer;
begin
inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion, AScale0Fonts);
inherited;
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
begin

4
lcl/include/toolbar.inc
View File

@ -342,9 +342,9 @@ begin
end;
procedure TToolBar.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean);
const AXProportion, AYProportion: Double; const AToDPI: Integer);
begin
inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion, AScale0Fonts);
inherited;
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
begin

7
lcl/include/wincontrol.inc
View File

@ -3836,15 +3836,14 @@ begin
end;
procedure TWinControl.AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy;
const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer;
const AScale0Fonts: Boolean);
const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer);
var
i: Integer;
begin
for i:=0 to ControlCount-1 do
Controls[i].AutoAdjustLayout(AMode, AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth, AScale0Fonts);
Controls[i].AutoAdjustLayout(AMode, AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth);
inherited AutoAdjustLayout(AMode, AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth, AScale0Fonts);
inherited;
end;
{------------------------------------------------------------------------------

3
lcl/stdctrls.pp
View File

@ -551,8 +551,7 @@ type
procedure SetStyle(Val: TListBoxStyle); virtual;
procedure DrawItem(Index: Integer; ARect: TRect; State: TOwnerDrawState); virtual;
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean);
override;
const AXProportion, AYProportion: Double; const AToDPI: Integer); override;
procedure DoSelectionChange(User: Boolean); virtual;
procedure SendItemIndex;
public