LCL: TControl: explicitely scale fonts with 0-height because they cannot be scaled automatically with TFont.PixelsPerInch

git-svn-id: trunk@54216 -

lcl/controls.pp

@@ -1421,6 +1421,7 @@ type
     procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
       const AXProportion, AYProportion: Double); virtual;
     class procedure DoFixDesignFontPPI(const AFont: TFont; const ADesignTimePPI: Integer);
+    class procedure DoScaleFontPPI(const AFont: TFont; const AProportion: Double);
   protected
     // actions
     function GetActionLinkClass: TControlActionLinkClass; virtual;
@@ -1542,6 +1543,7 @@ type
       const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer); virtual;
     procedure ShouldAutoAdjust(var AWidth, AHeight: Boolean); virtual;
     procedure FixDesignFontsPPI(const ADesignTimePPI: Integer); virtual;
+    procedure ScaleFontsPPI(const AProportion: Double); virtual;
   public
     constructor Create(TheOwner: TComponent);override;
     destructor Destroy; override;

lcl/include/control.inc

@@ -796,6 +796,14 @@ begin
   Result := MulDiv(ASize, ParentForm.DesignTimePPI, ParentForm.PixelsPerInch);
 end;
 
+procedure TControl.ScaleFontsPPI(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);
+end;
+
 {------------------------------------------------------------------------------
        TControl.ChangeScale
 
@@ -903,10 +911,9 @@ begin
   // 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);
-
-  // override this function - list all custom fonts in the overriden procedure
 end;
 
 procedure TControl.ExecuteCancelAction;
@@ -1189,7 +1196,13 @@ begin
 
   if FParentFont then
   begin
-    Font := FParent.Font;
+    Font.BeginUpdate;
+    try
+      Font.PixelsPerInch := FParent.Font.PixelsPerInch; // PixelsPerInch isn't assigned
+      Font := FParent.Font;
+    finally
+      Font.EndUpdate;
+    end;
     FParentFont := True;
   end;
   //call here for compatibility with older LCL code
@@ -1861,6 +1874,16 @@ begin
     OnShowHint(Self,HintInfo);
 end;
 
+class procedure TControl.DoScaleFontPPI(const AFont: TFont;
+  const AProportion: Double);
+begin
+  AFont.PixelsPerInch := Round(AFont.PixelsPerInch*AProportion);
+  // 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 then
+    AFont.Height := Round(GetFontData(AFont.Reference.Handle).Height*AProportion);
+end;
+
 function TControl.IsAParentAligning: boolean;
 var
   p: TWinControl;
@@ -2981,12 +3004,11 @@ var
   AAWidth, AAHeight: Boolean;
   NewLeft, NewTop, NewWidth, NewHeight, NewRight, NewBottom, OldWidth, OldHeight: Integer;
 begin
-  if not ParentFont or (Parent=nil) then
-    Font.PixelsPerInch := Round(Font.PixelsPerInch*AYProportion);
-
   // Apply the changes
   if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
   begin
+    if not ParentFont or (Parent=nil) then
+      ScaleFontsPPI(AYProportion);
 
     // Dimensions
     AAWidth := False;

lcl/include/customform.inc

@@ -1578,12 +1578,12 @@ begin
     Exit;
   end;
 
-  if not ParentFont or (Parent=nil) then
-    Font.PixelsPerInch := Round(Font.PixelsPerInch*AYProportion);
-
   // Apply the changes
   if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
   begin
+    if not ParentFont or (Parent=nil) then
+      ScaleFontsPPI(AYProportion);
+
     BorderSpacing.AutoAdjustLayout(AXProportion, AYProportion);
     Constraints.AutoAdjustLayout(AXProportion, AYProportion);