LCL: HighDPI: fix font scaling. Issue #31276

git-svn-id: trunk@54210 -

lcl/comctrls.pp

@@ -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;

lcl/controls.pp

@@ -1419,8 +1419,8 @@ type
     class function GetControlClassDefaultSize: TSize; virtual;
     function ColorIsStored: boolean; virtual;
     procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
-      const AXProportion, AYProportion: Double;
+      const AXProportion, AYProportion: Double; const AToDPI: Integer); virtual;
-      const AScale0Fonts: Boolean); 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 AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer); virtual;
-      const AScale0Fonts: Boolean); 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;
+      AToDPI, AOldFormWidth, ANewFormWidth: Integer); override;
-      const AScale0Fonts: Boolean); override;
   public
     constructor Create(TheOwner: TComponent);override;
     constructor CreateParented(AParentWindow: HWND);

lcl/forms.pp

@@ -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 AXProportion, AYProportion: Double; const AToDPI: Integer); override;
-      const AScale0Fonts: Boolean); 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;

lcl/grids.pas

@@ -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

lcl/groupededit.pp

@@ -179,8 +179,7 @@ type
     procedure SetTextHint(AValue: TTranslateString);
   protected
     procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
-      const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean);
+      const AXProportion, AYProportion: Double; const AToDPI: Integer); override;
-      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

lcl/include/control.inc

@@ -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
+  if not ParentFont or (Parent=nil) then
-  begin
+    Font.PixelsPerInch := AToDPI;
-    if Font.Size<>0 then
-      Font.Size := Round(Font.Size*AYProportion)
-    else
-      Font.Height := Round(GetFontData(Font.Reference.Handle).Height*AYProportion);
-  end;
 
   // 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 AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer);
-  const AScale0Fonts: Boolean);
 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.

lcl/include/customdesigncontrol.inc

@@ -21,20 +21,28 @@ begin
 end;
 
 procedure TCustomDesignControl.AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy;
-  const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer;
+  const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer);
-  const AScale0Fonts: Boolean);
 begin
-  inherited AutoAdjustLayout(AMode, AFromDPI, AToDPI, AOldFormWidth,
+  inherited;
-    ANewFormWidth, AScale0Fonts);
 
   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);

lcl/include/customform.inc

@@ -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),
+      Width, MulDiv(Width, Monitor.PixelsPerInch, PixelsPerInch));
-      Screen.PixelsPerInch<>Monitor.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
+  if not ParentFont or (Parent=nil) then
-  begin
+    Font.PixelsPerInch := AToDPI;
-    if Font.Size<>0 then
-      Font.Size := Round(Font.Size*AYProportion)
-    else
-      Font.Height := Round(GetFontData(Font.Reference.Handle).Height*AYProportion);
-  end;
 
   // 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;

lcl/include/customframe.inc

@@ -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;
 

lcl/include/customlistbox.inc

@@ -469,10 +469,11 @@ begin
   end;
 end;
 
-procedure TCustomListBox.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
+procedure TCustomListBox.DoAutoAdjustLayout(
-  const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean);
+  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

lcl/include/customlistview.inc

@@ -611,13 +611,14 @@ begin
       FOnSelectItem(Self, AItem, ASelected);
 end;
 
-procedure TCustomListView.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
+procedure TCustomListView.DoAutoAdjustLayout(
-  const AXProportion, AYProportion: Double; const AScale0Fonts: Boolean);
+  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

lcl/include/statusbar.inc

@@ -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

lcl/include/toolbar.inc

@@ -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

lcl/include/wincontrol.inc

@@ -3836,15 +3836,14 @@ begin
 end;
 
 procedure TWinControl.AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy;
-  const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer;
+  const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer);
-  const AScale0Fonts: Boolean);
 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;
 
 {------------------------------------------------------------------------------

lcl/stdctrls.pp

@@ -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);
+      const AXProportion, AYProportion: Double; const AToDPI: Integer); override;
-      override;
     procedure DoSelectionChange(User: Boolean); virtual;
     procedure SendItemIndex;
   public