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

git-svn-id: trunk@56962 -

ide/customformeditor.pp

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

lcl/controls.pp

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

lcl/forms.pp

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

lcl/include/control.inc

@@ -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,14 +1910,17 @@ 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);
-  AFont.PixelsPerInch := Round(AFont.PixelsPerInch*AProportion);
+  if AToPPI>0 then
+    AFont.PixelsPerInch := MulDiv(AFont.PixelsPerInch, AToPPI, AFont.PixelsPerInch)
+  else
+    AFont.PixelsPerInch := Round(AFont.PixelsPerInch*AProportion);
 end;
 
 function TControl.IsAParentAligning: boolean;
@@ -3123,100 +3115,95 @@ 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;
+    NewLeft := Left;
+    NewTop := Top;
+    NewWidth := Width;
+    NewHeight := Height;
+    OldWidth := Width;
+    OldHeight := Height;
 
-      // Dimensions
-      AAWidth := False;
-      AAHeight := False;
-      NewLeft := Left;
-      NewTop := Top;
-      NewWidth := Width;
-      NewHeight := Height;
-      OldWidth := Width;
-      OldHeight := Height;
+    ShouldAutoAdjust(AAWidth, AAHeight);
+    AAWidth := AAWidth and (Align in [alNone, alLeft, alRight])
+      and not((akLeft in Anchors) and (akRight in Anchors));
+    AAHeight := AAHeight and (Align in [alNone, alTop, alBottom])
+      and not((akTop in Anchors) and (akBottom in Anchors));
 
-      ShouldAutoAdjust(AAWidth, AAHeight);
-      AAWidth := AAWidth and (Align in [alNone, alLeft, alRight])
-        and not((akLeft in Anchors) and (akRight in Anchors));
-      AAHeight := AAHeight and (Align in [alNone, alTop, alBottom])
-        and not((akTop in Anchors) and (akBottom in Anchors));
-
-      if (Align=alNone) and (akLeft in Anchors) then
-        NewLeft := Round(NewLeft * AXProportion);
-      if (Align=alNone) and (akRight in Anchors) and (Parent<>nil)
-      and (AnchorSideRight.Control=nil) then
+    if (Align=alNone) and (akLeft in Anchors) then
+      NewLeft := Round(NewLeft * AXProportion);
+    if (Align=alNone) and (akRight in Anchors) and (Parent<>nil)
+    and (AnchorSideRight.Control=nil) then
+    begin
+      if not(akLeft in Anchors) then
       begin
-        if not(akLeft in Anchors) then
-        begin
-          NewRight := Round((Parent.ClientWidth-NewLeft-OldWidth) * AXProportion);
-          NewLeft := Parent.ClientWidth-NewRight-OldWidth
-        end else
-        begin
-          NewRight := Round((Parent.ClientWidth-Left-OldWidth) * AXProportion);
-          NewWidth := Parent.ClientWidth-NewLeft-NewRight;
-        end;
-      end;
-
-      if (Align=alNone) and (akTop in Anchors) then
-        NewTop := Round(NewTop * AYProportion);
-      if (Align=alNone) and (akBottom in Anchors) and (Parent<>nil)
-      and (AnchorSideBottom.Control=nil) then
+        NewRight := Round((Parent.ClientWidth-NewLeft-OldWidth) * AXProportion);
+        NewLeft := Parent.ClientWidth-NewRight-OldWidth
+      end else
       begin
-        if not(akTop in Anchors) then
-        begin
-          NewBottom := Round((Parent.ClientHeight-NewTop-OldHeight) * AYProportion);
-          NewTop := Parent.ClientHeight-NewBottom-OldHeight
-        end else
-        begin
-          NewBottom := Round((Parent.ClientHeight-Top-OldHeight) * AYProportion);
-          NewHeight := Parent.ClientHeight-NewTop-NewBottom;
-        end;
+        NewRight := Round((Parent.ClientWidth-Left-OldWidth) * AXProportion);
+        NewWidth := Parent.ClientWidth-NewLeft-NewRight;
       end;
+    end;
 
-      if AAWidth then
-        NewWidth := Round(Width * AXProportion);
-      if AAHeight then
-        NewHeight := Round(Height * AYProportion);
-
-      BorderSpacing.AutoAdjustLayout(AXProportion, AYProportion);
-      Constraints.AutoAdjustLayout(AXProportion, AYProportion);
-
-      NewBaseLeft := NewLeft;
-      NewBaseTop := NewTop;
-      NewBaseWidth := NewWidth;
-      NewBaseHeight := NewHeight;
-      NewWidth := Constraints.MinMaxWidth(NewWidth);
-      NewHeight := Constraints.MinMaxHeight(NewHeight);
-
-      if AAWidth or (NewBaseWidth<>NewWidth) then
+    if (Align=alNone) and (akTop in Anchors) then
+      NewTop := Round(NewTop * AYProportion);
+    if (Align=alNone) and (akBottom in Anchors) and (Parent<>nil)
+    and (AnchorSideBottom.Control=nil) then
+    begin
+      if not(akTop in Anchors) then
       begin
-        if akRight in Anchors then
-          NewLeft := NewLeft-NewWidth+OldWidth;
-      end;
-      if AAHeight or (NewBaseHeight<>NewHeight) then
+        NewBottom := Round((Parent.ClientHeight-NewTop-OldHeight) * AYProportion);
+        NewTop := Parent.ClientHeight-NewBottom-OldHeight
+      end else
       begin
-        if akBottom in Anchors then
-          NewTop := NewTop-NewHeight+OldHeight;
+        NewBottom := Round((Parent.ClientHeight-Top-OldHeight) * AYProportion);
+        NewHeight := Parent.ClientHeight-NewTop-NewBottom;
       end;
-      if AAWidth and (akRight in Anchors) then
-        NewBaseLeft := NewBaseLeft-NewBaseWidth+OldWidth;
-      if AAHeight and (akBottom in Anchors) then
-        NewBaseTop := NewBaseTop-NewBaseHeight+OldHeight;
+    end;
 
-      FBaseBounds.Left:=NewBaseLeft;
-      FBaseBounds.Top:=NewBaseTop;
-      FBaseBounds.Right:=NewBaseLeft+NewBaseWidth;
-      FBaseBounds.Bottom:=NewBaseTop+NewBaseHeight;
+    if AAWidth then
+      NewWidth := Round(Width * AXProportion);
+    if AAHeight then
+      NewHeight := Round(Height * AYProportion);
+
+    BorderSpacing.AutoAdjustLayout(AXProportion, AYProportion);
+    Constraints.AutoAdjustLayout(AXProportion, AYProportion);
+
+    NewBaseLeft := NewLeft;
+    NewBaseTop := NewTop;
+    NewBaseWidth := NewWidth;
+    NewBaseHeight := NewHeight;
+    NewWidth := Constraints.MinMaxWidth(NewWidth);
+    NewHeight := Constraints.MinMaxHeight(NewHeight);
+
+    if AAWidth or (NewBaseWidth<>NewWidth) then
+    begin
+      if akRight in Anchors then
+        NewLeft := NewLeft-NewWidth+OldWidth;
+    end;
+    if AAHeight or (NewBaseHeight<>NewHeight) then
+    begin
+      if akBottom in Anchors then
+        NewTop := NewTop-NewHeight+OldHeight;
+    end;
+    if AAWidth and (akRight in Anchors) then
+      NewBaseLeft := NewBaseLeft-NewBaseWidth+OldWidth;
+    if AAHeight and (akBottom in Anchors) then
+      NewBaseTop := NewBaseTop-NewBaseHeight+OldHeight;
+
+    FBaseBounds.Left:=NewBaseLeft;
+    FBaseBounds.Top:=NewBaseTop;
+    FBaseBounds.Right:=NewBaseLeft+NewBaseWidth;
+    FBaseBounds.Bottom:=NewBaseTop+NewBaseHeight;
+    if Parent<>nil then
+    begin
       FBaseParentClientSize.cx:=Parent.ClientWidth;
       FBaseParentClientSize.cy:=Parent.ClientHeight;
-
-      SetBoundsKeepBase(NewLeft, NewTop, NewWidth, NewHeight);
-    finally
-      EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TControl.DoAutoAdjustLayout'){$ENDIF};
     end;
+
+    SetBoundsKeepBase(NewLeft, NewTop, NewWidth, NewHeight);
   end;
 end;
 
@@ -4169,7 +4156,15 @@ begin
   if AFromPPI > 0 then lYProportion := AToPPI / AFromPPI
   else lYProportion := 1.0;
 
-  DoAutoAdjustLayout(lMode, lXProportion, lYProportion);
+  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.

lcl/include/customdesigncontrol.inc

@@ -46,46 +46,21 @@ 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);
 
-      NewWidth := Round(Width*AXProportion);
-      NewHeight := Round(Height*AYProportion);
+    BorderSpacing.AutoAdjustLayout(AXProportion, AYProportion);
+    Constraints.AutoAdjustLayout(AXProportion, AYProportion);
 
-      BorderSpacing.AutoAdjustLayout(AXProportion, AYProportion);
-      Constraints.AutoAdjustLayout(AXProportion, AYProportion);
-
-      SetBounds(Left, Top, NewWidth, NewHeight);
-    finally
-      EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TCustomForm.DoAutoAdjustLayout'){$ENDIF};
-    end;
+    SetBounds(Left, Top, NewWidth, NewHeight);
   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);