paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-12 14:09:31 +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) TCustomFrame = class(TScrollingWinControl)
private private
FDesignTimeDPI: Integer; FDesignTimeDPI: Integer;
FPixelsPerInch: Integer;
procedure AddActionList(ActionList: TCustomActionList); procedure AddActionList(ActionList: TCustomActionList);
procedure RemoveActionList(ActionList: TCustomActionList); procedure RemoveActionList(ActionList: TCustomActionList);
procedure ReadDesignLeft(Reader: TReader); procedure ReadDesignLeft(Reader: TReader);
@ -273,12 +274,16 @@ type
procedure CalculatePreferredSize(var PreferredWidth, procedure CalculatePreferredSize(var PreferredWidth,
PreferredHeight: integer; WithThemeSpace: Boolean); override; PreferredHeight: integer; WithThemeSpace: Boolean); override;
procedure Loaded; override; procedure Loaded; override;
procedure AutoAdjustLayout(AMode: TLayoutAdjustmentPolicy; const AFromDPI,
AToDPI, AOldFormWidth, ANewFormWidth: Integer;
const AScaleFonts: Boolean); override;
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override; procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
class function GetControlClassDefaultSize: TSize; override; class function GetControlClassDefaultSize: TSize; override;
public public
property DesignTimeDPI: Integer read FDesignTimeDPI write SetDesignTimeDPI default 96; property DesignTimeDPI: Integer read FDesignTimeDPI write SetDesignTimeDPI default 96;
property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
end; end;
TCustomFrameClass = class of TCustomFrame; TCustomFrameClass = class of TCustomFrame;

22
lcl/include/customframe.inc
View File

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