View Issue Details
ID | Project | Category | View Status | Date Submitted | Last Update |
---|---|---|---|---|---|
0017250 | Lazarus | LCL | public | 2010-08-23 20:42 | 2010-11-21 19:08 |
Reporter | Zaher Dirkey | Assigned To | Paul Ishenin | ||
Priority | normal | Severity | minor | Reproducibility | always |
Status | closed | Resolution | fixed | ||
Product Version | Product Build | ||||
Target Version | 0.9.30 | Fixed in Version | 0.9.29 (SVN) | ||
Summary | 0017250: [PATCH] Add ScaleBy and ChangeScale to LCL | ||||
Description | I implemented ChangeScale and add ScaleBy method to control, just simple code to scale controls. Not linked to PixelsPerInch yet to keep it free of bugs and not effect to who not call ScaleBy. Thanks | ||||
Tags | sizing | ||||
Fixed in Revision | 28174 | ||||
LazTarget | 0.9.30 | ||||
Widgetset | GTK, GTK 2, Win32/Win64, WinCE, Carbon, QT, fpGUI | ||||
Attached Files |
|
related to | 0018233 | closed | Juha Manninen | ScaleDPI: unit for making Windows 7 High DPI Applications |
2010-08-23 20:42
|
ChangeScale.patch (4,403 bytes)
Index: controls.pp =================================================================== --- controls.pp (revision 27167) +++ controls.pp (working copy) @@ -1052,6 +1052,7 @@ procedure UpdateAnchorRules; procedure ChangeBounds(ALeft, ATop, AWidth, AHeight: integer; KeepBase: boolean); virtual; procedure DoSetBounds(ALeft, ATop, AWidth, AHeight: integer); virtual; + procedure ScaleConstraints(Multiplier, Divider: Integer); procedure ChangeScale(Multiplier, Divider: Integer); virtual; function CanAutoSize(var NewWidth, NewHeight: Integer): Boolean; virtual; procedure UpdateAlignIndex; @@ -1738,6 +1739,8 @@ procedure PaintHandler(var TheMessage: TLMPaint); procedure PaintWindow(DC: HDC); virtual; procedure CreateBrush; virtual; + procedure ScaleControls(Multiplier, Divider: Integer); virtual; + procedure ChangeScale(Multiplier, Divider: Integer); override; protected // messages procedure CMBiDiModeChanged(var Message: TLMessage); message CM_BIDIMODECHANGED; @@ -1948,6 +1951,7 @@ procedure Update; override; procedure SetFocus; virtual; procedure FlipChildren(AllLevels: Boolean); virtual; + procedure ScaleBy(Multiplier, Divider: Integer); function GetDockCaption(AControl: TControl): String; virtual; procedure UpdateDockCaption(Exclude: TControl = nil); virtual; procedure GetTabOrderList(List: TFPList); Index: include/control.inc =================================================================== --- include/control.inc (revision 27167) +++ include/control.inc (working copy) @@ -450,15 +450,42 @@ if Parent <> nil then Parent.InvalidatePreferredSize; end; +procedure TControl.ScaleConstraints(Multiplier, Divider: Integer); +begin + with Constraints do + begin + if MinWidth > 0 then + MinWidth := MulDiv(MinWidth, Multiplier, Divider); + if MaxWidth > 0 then + MaxWidth := MulDiv(MaxWidth, Multiplier, Divider); + if MinHeight > 0 then + MinHeight := MulDiv(MinHeight, Multiplier, Divider); + if MaxHeight > 0 then + MaxHeight := MulDiv(MaxHeight, Multiplier, Divider); + end; +end; + {------------------------------------------------------------------------------ TControl.ChangeScale Scale contorl by factor Multiplier/Divider ------------------------------------------------------------------------------} procedure TControl.ChangeScale(Multiplier, Divider: Integer); +var + R: TRect; begin - // TODO: TCONTROL.CHANGESCALE - //Assert(False, 'Trace:TODO: [TControl.ChangeScale]'); + if Multiplier <> Divider then + begin + ScaleConstraints(Multiplier, Divider); + if not ParentFont then + Font.Size := MulDiv(Font.Size, Multiplier, Divider); + R := BaseBounds; + R.Left := MulDiv(R.Left, Multiplier, Divider); + R.Top := MulDiv(R.Top, Multiplier, Divider); + R.Right := MulDiv(R.Right, Multiplier, Divider); + R.Bottom := MulDiv(R.Bottom, Multiplier, Divider); + BoundsRect := R; + end; end; {------------------------------------------------------------------------------ Index: include/wincontrol.inc =================================================================== --- include/wincontrol.inc (revision 27167) +++ include/wincontrol.inc (working copy) @@ -4389,6 +4389,11 @@ end; end; +procedure TWinControl.ScaleBy(Multiplier, Divider: Integer); +begin + ChangeScale(Multiplier, Divider); +end; + {------------------------------------------------------------------------------} { TWinControl FindNextControl } {------------------------------------------------------------------------------} @@ -4817,6 +4822,28 @@ // ToDo: ParentColor end; +procedure TWinControl.ScaleControls(Multiplier, Divider: Integer); +var + i: Integer; +begin + for i := 0 to ControlCount - 1 do + Controls[i].ChangeScale(Multiplier, Divider); +end; + +procedure TWinControl.ChangeScale(Multiplier, Divider: Integer); +begin + if Multiplier <> Divider then + begin + DisableAlign; + try + inherited; + ScaleControls(Multiplier, Divider); + finally + EnableAlign; + end; + end; +end; + {------------------------------------------------------------------------------ procedure TWinControl.EraseBackground; ------------------------------------------------------------------------------} |
|
I had done something like this (to my projects) and I do not know how Delphi does it, but scaling controls in that way will IMHO "ruin" layouts with anchors and controls that must grow from right to left. If anyone wants to check my code it is attached as functions. |
2010-08-23 23:37
|
uscaleby.pas (4,686 bytes)
unit uscaleby; {$mode objfpc}{$H+} interface uses Classes, SysUtils,Forms,Controls; type TCustomClassScaler=tclass; TScaleProcedure=procedure(const AControl: TControl;const AOrigin,ATarget: SizeUint); TRegisteredScaler=record ClassToScale: TCustomClassScaler; ClassScaleProcedure: TScaleProcedure; end; procedure ScaleBy(const AControl: TControl;const AOrigin,ATarget: SizeUint); procedure ScaleByRecursive(const AControl: TControl;const AOrigin,ATarget: SizeUint); procedure ScaleRectBy(var ARect: TRect;const AOrigin,ATarget: SizeUint); procedure ScaleByRegisterScaler(const AScaleClass: tclass;const AScaler: TScaleProcedure); implementation var Scalers: array of TRegisteredScaler; function FindRegisteredScaler(const AControl: TControl): TScaleProcedure; forward; procedure ScaleBy(const AControl: TControl; const AOrigin, ATarget: SizeUint ); var TheRect: TRect; begin if AOrigin=ATarget then exit; //If control is aligned only some things should be chaned based in which //alignement it has. if AControl.Align=alClient then begin //Nothing to do, it has been autoresized when the parent has been resized. Exit; end; //First scale the constraints. TheRect.Left := AControl.Constraints.MinWidth; TheRect.Right := AControl.Constraints.MaxWidth; TheRect.Top := AControl.Constraints.MinHeight; TheRect.Bottom := AControl.Constraints.MaxHeight; ScaleRectBy(TheRect,AOrigin,ATarget); AControl.Constraints.MinWidth := TheRect.Left; AControl.Constraints.MaxWidth := TheRect.Right; AControl.Constraints.MinHeight := TheRect.Top; AControl.Constraints.MaxHeight := TheRect.Bottom; //Now scale the origin and size of the control. TheRect.Left := AControl.Left; TheRect.Right := AControl.Width; TheRect.Top := AControl.Top; TheRect.Bottom := AControl.Height; ScaleRectBy(TheRect,AOrigin,ATarget); if (AControl.Align=AlNone) or (AControl.Align=alCustom) then begin if (akLeft in AControl.Anchors) then begin AControl.Left := TheRect.Left; end; if not (akRight in AControl.Anchors) then begin AControl.Width := TheRect.Right; end; if (akTop in AControl.Anchors) then begin AControl.Top := TheRect.Top; end; if not (akBottom in AControl.Anchors) then begin AControl.Height := TheRect.Bottom; end; end else begin if ((AControl.Align=alTop) or (AControl.Align=alBottom)) and (not (akBottom in AControl.Anchors)) then begin //Only scale the height... AControl.Height := TheRect.Bottom; end else if ((AControl.Align=alLeft) or (AControl.Align=alRight)) and (not (akRight in AControl.Anchors)) then begin //Only scale the width... AControl.Width := TheRect.Right; end; end; TheRect.Left := AControl.Left; TheRect.Right := AControl.Width; TheRect.Top := AControl.Top; TheRect.Bottom := AControl.Height; end; procedure ScaleByRecursive(const AControl: TControl; const AOrigin, ATarget: SizeUint); var j: SizeUint; TheControl: TControl; TheWinControl: TWinControl; Scaler: TScaleProcedure; begin if AOrigin=ATarget then exit; Scaler:=FindRegisteredScaler(AControl); Scaler(AControl,AOrigin,ATarget); if AControl is TWinControl then begin TheWinControl:=TWinControl(AControl); if TheWinControl.ControlCount>0 then begin for j := 0 to TheWinControl.ControlCount-1 do begin TheControl:=TheWinControl.Controls[j]; if TheControl is TControl then begin ScaleByRecursive(TheWinControl.Controls[j],AOrigin,ATarget); end; end; end; end; end; procedure ScaleRectBy(var ARect: TRect; const AOrigin, ATarget: SizeUint); begin ARect.Top:=ARect.Top*int64(ATarget) div int64(AOrigin); ARect.Left:=ARect.Left*int64(ATarget) div int64(AOrigin); ARect.Right:=ARect.Right*int64(ATarget) div int64(AOrigin); ARect.Bottom:=ARect.Bottom*int64(ATarget) div int64(AOrigin); end; procedure ScaleByRegisterScaler(const AScaleClass: tclass; const AScaler: TScaleProcedure); begin SetLength(Scalers,Length(Scalers)+1); with Scalers[High(Scalers)] do begin ClassToScale:=AScaleClass; ClassScaleProcedure:=AScaler; end; end; function FindRegisteredScaler(const AControl: TControl): TScaleProcedure; var j: SizeInt; begin for j := 0 to High(Scalers) do begin if AControl.ClassType=Scalers[j].ClassToScale then begin Result:=Scalers[j].ClassScaleProcedure; Exit; end; end; //Default is the default ScaleBy Result:=@ScaleBy; end; end. |
2010-08-23 23:37
|
uscalebycomctrls.pas (1,102 bytes)
unit uscalebycomctrls; {$mode objfpc}{$H+} interface uses Classes, SysUtils,uscaleby,Controls,ComCtrls; implementation procedure ListViewScaleBy(const AControl: TControl; const AOrigin, ATarget: SizeUint); var j: SizeUint; TheCol: TListColumn; ListView: TListView; begin ListView:=TListView(AControl); //ListView only scales the columns size in report mode for j := 0 to ListView.Columns.Count-1 do begin TheCol:=ListView.Columns[j]; TheCol.Width:=TheCol.Width*ATarget div AOrigin; end; end; procedure StatusBarScaleBy(const AControl: TControl; const AOrigin, ATarget: SizeUint); var j: SizeUint; ThePanel: TStatusPanel; StatusBar: TStatusBar; begin StatusBar:=TStatusBar(AControl); //Status only scales the panel width for j := 0 to StatusBar.Panels.Count-1 do begin ThePanel:=StatusBar.Panels[j]; ThePanel.Width:=ThePanel.Width*int64(ATarget) div AOrigin; end; end; initialization ScaleByRegisterScaler(TListView,@ListViewScaleBy); ScaleByRegisterScaler(TStatusBar,@StatusBarScaleBy); end. |
|
Target 0.9.30, for review of the patch. |
|
Thanks, applied |
|
Tested, worked fine, thanks |
Date Modified | Username | Field | Change |
---|---|---|---|
2010-08-23 20:42 | Zaher Dirkey | New Issue | |
2010-08-23 20:42 | Zaher Dirkey | File Added: ChangeScale.patch | |
2010-08-23 20:42 | Zaher Dirkey | Widgetset | => GTK, GTK 2, Win32/Win64, WinCE, Carbon, QT, fpGUI |
2010-08-23 20:43 | Zaher Dirkey | Tag Attached: sizing | |
2010-08-23 23:37 | José Mejuto | Note Added: 0040426 | |
2010-08-23 23:37 | José Mejuto | File Added: uscaleby.pas | |
2010-08-23 23:37 | José Mejuto | File Added: uscalebycomctrls.pas | |
2010-10-29 12:40 | Vincent Snijders | LazTarget | => 0.9.30 |
2010-10-29 12:40 | Vincent Snijders | Status | new => acknowledged |
2010-10-29 12:40 | Vincent Snijders | Note Added: 0042311 | |
2010-10-29 12:40 | Vincent Snijders | Target Version | => 0.9.30 |
2010-11-10 07:47 | Paul Ishenin | Fixed in Revision | => 28174 |
2010-11-10 07:47 | Paul Ishenin | Status | acknowledged => resolved |
2010-11-10 07:47 | Paul Ishenin | Fixed in Version | => 0.9.29 (SVN) |
2010-11-10 07:47 | Paul Ishenin | Resolution | open => fixed |
2010-11-10 07:47 | Paul Ishenin | Assigned To | => Paul Ishenin |
2010-11-10 07:47 | Paul Ishenin | Note Added: 0042937 | |
2010-11-21 19:08 | Zaher Dirkey | Status | resolved => closed |
2010-11-21 19:08 | Zaher Dirkey | Note Added: 0043336 | |
2010-12-17 09:08 | Vincent Snijders | Relationship added | related to 0018233 |