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

lcl: forms: highDPI: Implement TFrame.PixelsPerInch

Browse Source 
git-svn-id: trunk@53536 -
This commit is contained in:
ondrej 2016-12-03 06:47:02 +00:00
parent c5774398cb
commit 38e6533972
2 changed files with 27 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
lcl/forms.pp
View File

@ -257,6 +257,7 @@ type
TCustomFrame = class(TScrollingWinControl)
private
FDesignTimeDPI: Integer;
FPixelsPerInch: Integer;
procedure AddActionList(ActionList: TCustomActionList);
procedure RemoveActionList(ActionList: TCustomActionList);
procedure ReadDesignLeft(Reader: TReader);
@ -273,12 +274,16 @@ type
procedure CalculatePreferredSize(var PreferredWidth,
PreferredHeight: integer; WithThemeSpace: Boolean); override;
procedure Loaded; override;
procedure AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy; const AFromDPI,
AToDPI, AOldFormWidth, ANewFormWidth: Integer;
const AScaleFonts: Boolean); override;
public
constructor Create(AOwner: TComponent); override;
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
class function GetControlClassDefaultSize: TSize; override;
public
property DesignTimeDPI: Integer read FDesignTimeDPI write SetDesignTimeDPI default 96;
property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
end;
TCustomFrameClass = class of TCustomFrame;

22
lcl/include/customframe.inc
View File

@ -20,6 +20,16 @@ begin
ParentForm.DoAddActionList(ActionList);
end;
procedure TCustomFrame.AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy;
const AFromDPI, AToDPI, AOldFormWidth, ANewFormWidth: Integer;
const AScaleFonts: Boolean);
begin
inherited AutoAdjustLayout(AMode, AFromDPI, AToDPI, AOldFormWidth,
ANewFormWidth, AScaleFonts);
FPixelsPerInch := AToDPI;
end;
procedure TCustomFrame.RemoveActionList(ActionList: TCustomActionList);
var
ParentForm: TCustomForm;
@ -125,15 +135,25 @@ procedure TCustomFrame.SetParent(AParent: TWinControl);
end;
end;
var
ParentForm: TCustomForm;
begin
if Parent=AParent then exit;
if Parent<>nil then
UpdateActionLists(Self,opRemove);
if (Parent=nil) and HandleAllocated then
DestroyHandle;
inherited SetParent(AParent);
if Parent <> nil then
begin
UpdateActionLists(Self,opInsert);
ParentForm := GetParentForm(Self);
if (ParentForm<>nil) and ParentForm.Scaled
and (ParentForm.PixelsPerInch<>PixelsPerInch) then
AutoAdjustLayout(lapAutoAdjustForDPI, PixelsPerInch, ParentForm.PixelsPerInch, 0, 0, False);
end;
end;
class function TCustomFrame.GetControlClassDefaultSize: TSize;
@ -148,6 +168,7 @@ begin
if csDesigning in ComponentState then
FDesignTimeDPI := Screen.PixelsPerInch;
FPixelsPerInch := FDesignTimeDPI;
end;
procedure TCustomFrame.DefineProperties(Filer: TFiler);
@ -182,6 +203,7 @@ begin
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents, csSetCaption,
csDoubleClicks, csParentBackground];
FDesignTimeDPI := 96;
FPixelsPerInch := FDesignTimeDPI;
if (ClassType<>TFrame) and ([csDesignInstance, csDesigning]*ComponentState=[]) then
begin
if not InitInheritedComponent(Self, TFrame) then