diff --git a/ide/customformeditor.pp b/ide/customformeditor.pp index 0dd8a53aaf..46002a73e6 100644 --- a/ide/customformeditor.pp +++ b/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) diff --git a/lcl/comctrls.pp b/lcl/comctrls.pp index ce2cbd6d19..2e2f9734c7 100644 --- a/lcl/comctrls.pp +++ b/lcl/comctrls.pp @@ -1238,6 +1238,7 @@ type function GetItem(const AIndex: Integer): TListColumn; procedure WSCreateColumns; procedure SetItem(const AIndex: Integer; const AValue: TListColumn); + procedure DoFinalizeWnd; protected function GetOwner: TPersistent; override; public diff --git a/lcl/controls.pp b/lcl/controls.pp index 96fa686a78..8d870750c6 100644 --- a/lcl/controls.pp +++ b/lcl/controls.pp @@ -1423,7 +1423,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; @@ -1550,8 +1550,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; diff --git a/lcl/forms.pp b/lcl/forms.pp index 0d40ad87b2..30f3e1dabf 100644 --- a/lcl/forms.pp +++ b/lcl/forms.pp @@ -265,13 +265,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 DesignTimeDPI: Integer read FDesignTimePPI write SetDesignTimePPI stored False; deprecated {$IFNDEF FPDOC}'Use DesignTimePPI instead. DesignTimeDPI will be removed in 1.8'{$ENDIF}; property DesignTimePPI: Integer read FDesignTimePPI write SetDesignTimePPI default 96; diff --git a/lcl/include/control.inc b/lcl/include/control.inc index 671bd7cd73..a120a715b3 100644 --- a/lcl/include/control.inc +++ b/lcl/include/control.inc @@ -827,12 +827,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; {------------------------------------------------------------------------------ @@ -935,18 +936,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; @@ -1463,8 +1452,6 @@ end; ------------------------------------------------------------------------------} procedure TControl.DoConstraintsChange(Sender : TObject); begin - Width:=Constraints.MinMaxWidth(Width); - Height:=Constraints.MinMaxHeight(Height); AdjustSize; end; @@ -1916,14 +1903,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; @@ -3061,100 +3051,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; @@ -4107,7 +4092,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. diff --git a/lcl/include/customdesigncontrol.inc b/lcl/include/customdesigncontrol.inc index 63c38f7438..a176e7e56d 100644 --- a/lcl/include/customdesigncontrol.inc +++ b/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); diff --git a/lcl/include/customform.inc b/lcl/include/customform.inc index 5ddf42bd75..375e1c8335 100644 --- a/lcl/include/customform.inc +++ b/lcl/include/customform.inc @@ -1208,6 +1208,8 @@ begin end; procedure TCustomForm.SetParent(NewParent: TWinControl); +var + ParentForm: TCustomForm; begin if Parent = NewParent then exit; DisableAutoSizing{$IFDEF DebugDisableAutoSizing}('TCustomForm.SetParent'){$ENDIF}; @@ -1216,6 +1218,14 @@ begin inherited SetParent(NewParent); if (Parent = nil) and Visible then HandleNeeded; + + if Parent <> nil then + begin + ParentForm := GetParentForm(Self); + if Application.Scaled and (ParentForm<>nil) and ParentForm.Scaled + and (ParentForm.PixelsPerInch<>PixelsPerInch) then + AutoAdjustLayout(lapAutoAdjustForDPI, PixelsPerInch, ParentForm.PixelsPerInch, 0, 0); + end; finally EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TCustomForm.SetParent'){$ENDIF}; end; @@ -2364,11 +2374,23 @@ begin end; function TCustomForm.GetMonitor: TMonitor; +var + ParentForm: TCustomForm; begin - if HandleAllocated then - Result := Screen.MonitorFromWindow(Handle, mdNearest) - else - Result :=Screen.MonitorFromPoint(point(Left,Top)); + if Assigned(Parent) then + begin + ParentForm := GetParentForm(Self); + if Assigned(ParentForm) then + Result := ParentForm.Monitor + else + Result := nil; + end else + begin + if HandleAllocated then + Result := Screen.MonitorFromWindow(Handle, mdNearest) + else + Result := Screen.MonitorFromPoint(point(Left,Top)); + end; end; {------------------------------------------------------------------------------ diff --git a/lcl/include/customlistview.inc b/lcl/include/customlistview.inc index 9b60ff5701..87a161ff31 100644 --- a/lcl/include/customlistview.inc +++ b/lcl/include/customlistview.inc @@ -1124,6 +1124,7 @@ begin FViewOriginCache := TWSCustomListViewClass(WidgetSetClass).GetViewOrigin(Self); if not OwnerData then FListItems.DoFinalizeWnd; + Columns.DoFinalizeWnd; inherited FinalizeWnd; end; diff --git a/lcl/include/listcolumn.inc b/lcl/include/listcolumn.inc index 73d8e5d5c7..01c914e6f0 100644 --- a/lcl/include/listcolumn.inc +++ b/lcl/include/listcolumn.inc @@ -178,7 +178,7 @@ begin else if (MaxWidth > 0) and (W > MaxWidth) then W := MaxWidth; - if FWidth = W then Exit; + if Width = W then Exit; // compare with Width instead of FWidth - FWidth is not updated from the WS automatically FWidth := W; Changed(False); if not WSUpdateAllowed then Exit; diff --git a/lcl/include/listcolumns.inc b/lcl/include/listcolumns.inc index 7570a5b6bf..1c13dc06a2 100644 --- a/lcl/include/listcolumns.inc +++ b/lcl/include/listcolumns.inc @@ -62,6 +62,14 @@ begin EndUpdate; end; +procedure TListColumns.DoFinalizeWnd; +var + I: Integer; +begin + for I := 0 to Count-1 do + Items[I].GetWidth; // store real width from WS into FWidth +end; + procedure TListColumns.Update(Item: TCollectionItem); begin if (Item = nil) and FNeedsUpdate then diff --git a/lcl/include/wincontrol.inc b/lcl/include/wincontrol.inc index a13e00f245..0c932332b2 100644 --- a/lcl/include/wincontrol.inc +++ b/lcl/include/wincontrol.inc @@ -2553,6 +2553,7 @@ var or (CurControl.Anchors <> [akLeft, akTop]) or (CurControl.AnchorSide[akLeft].Control<>nil) or (CurControl.AnchorSide[akTop].Control<>nil) + or (cfAutoSizeNeeded in CurControl.FControlFlags) or (ChildSizing.Layout<>cclNone) then Exit; end;