paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-27 11:50:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

lcl: forms: scale TFrame the same as TForm. Issue #31807

Browse Source 
git-svn-id: trunk@54898 -
This commit is contained in:
ondrej 2017-05-13 20:00:29 +00:00
parent 51b03efe92
commit 96886b5551
3 changed files with 35 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
lcl/forms.pp
View File

@ -267,6 +267,8 @@ type
procedure AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy; const AFromPPI, procedure AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy; const AFromPPI,
AToPPI, AOldFormWidth, ANewFormWidth: Integer); override; AToPPI, AOldFormWidth, ANewFormWidth: Integer); override;
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double); override;
procedure Loaded; override; procedure Loaded; override;
public public
constructor Create(TheOwner: TComponent); override; constructor Create(TheOwner: TComponent); override;
@ -547,8 +549,6 @@ type
procedure CreateParams(var Params: TCreateParams); override; procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override; procedure CreateWnd; override;
procedure Deactivate; virtual; procedure Deactivate; virtual;
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double); override;
procedure DoClose(var CloseAction: TCloseAction); virtual; procedure DoClose(var CloseAction: TCloseAction); virtual;
procedure DoCreate; virtual; procedure DoCreate; virtual;
procedure DoDestroy; virtual; procedure DoDestroy; virtual;

33
lcl/include/customdesigncontrol.inc
View File

@ -30,6 +30,39 @@ begin
FPixelsPerInch := AToPPI; FPixelsPerInch := AToPPI;
end; end;
procedure TCustomDesignControl.DoAutoAdjustLayout(
const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double
);
var
NewWidth, NewHeight: Integer;
begin
if Assigned(Parent) then
begin
inherited;
Exit;
end;
// 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);
BorderSpacing.AutoAdjustLayout(AXProportion, AYProportion);
Constraints.AutoAdjustLayout(AXProportion, AYProportion);
SetBounds(Left, Top, NewWidth, NewHeight);
finally
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TCustomForm.DoAutoAdjustLayout'){$ENDIF};
end;
end;
end;
procedure TCustomDesignControl.Loaded; procedure TCustomDesignControl.Loaded;
procedure FixChildren(const AParent: TWinControl); procedure FixChildren(const AParent: TWinControl);
var var

32
lcl/include/customform.inc
View File

@ -1560,38 +1560,6 @@ begin
end; end;
end; end;
procedure TCustomForm.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double);
var
NewWidth, NewHeight: Integer;
begin
if Assigned(Parent) then
begin
inherited;
Exit;
end;
// 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);
BorderSpacing.AutoAdjustLayout(AXProportion, AYProportion);
Constraints.AutoAdjustLayout(AXProportion, AYProportion);
SetBounds(Left, Top, NewWidth, NewHeight);
finally
EnableAutoSizing{$IFDEF DebugDisableAutoSizing}('TCustomForm.DoAutoAdjustLayout'){$ENDIF};
end;
end;
end;
procedure TCustomForm.DoRemoveActionList(List: TCustomActionList); procedure TCustomForm.DoRemoveActionList(List: TCustomActionList);
begin begin
if FActionLists<>nil then if FActionLists<>nil then