1 // SPDX-License-Identifier: GPL-3.0-only
2 unit LCScaleDPI;
3
4 {$mode objfpc}{$H+}
5
6 interface
7
8 uses
9 Forms, Graphics, Controls, ComCtrls;
10
11 procedure ScaleForms(FromDPI: Integer);
12 procedure ScaleControl(Control: TControl; FromDPI: Integer;
13 ToDPI_X: Integer = 0; ToDPI_Y: Integer = 0; ScaleToolbar: boolean = false);
14 procedure ScaleImageList(SourceList: TImageList; newWidth, newHeight: Integer; TargetList: TImageList);
DoScaleXnull15 function DoScaleX(Size: Integer; FromDPI: Integer; ToDPI: Integer = 0): integer;
DoScaleYnull16 function DoScaleY(Size: Integer; FromDPI: Integer; ToDPI: Integer = 0): integer;
DoScaleXFnull17 function DoScaleXF(Size: single; FromDPI: Integer; ToDPI: Integer = 0): single;
DoScaleYFnull18 function DoScaleYF(Size: single; FromDPI: Integer; ToDPI: Integer = 0): single;
19
20 implementation
21
22 uses BGRABitmap, BGRABitmapTypes, LCLType;
23
24 procedure ScaleForms(FromDPI: Integer);
25 var
26 i: Integer;
27 begin
28 for i:=0 to Screen.FormCount-1 do begin
29 ScaleControl(Screen.Forms[i],FromDPI);
30 end;
31 end;
32
33 procedure ScaleImageList(SourceList: TImageList; newWidth, newHeight: Integer; TargetList: TImageList);
34 var
35 TempBmp: TBitmap;
36 TempBGRA: array of TBGRABitmap;
37 i: Integer;
38
39 begin
40 if (TargetList = SourceList) and (newWidth = SourceList.Width) and
41 (newHeight = SourceList.Height) then exit;
42
43 setlength(TempBGRA, SourceList.Count);
44 TempBmp := TBitmap.Create;
45 for i := 0 to SourceList.Count-1 do
46 begin
47 SourceList.GetBitmap(i,TempBmp);
48 TempBGRA[i] := TBGRABitmap.Create(TempBmp);
49 TempBGRA[i].ResampleFilter := rfBestQuality;
50 if (TempBGRA[i].width=0) or (TempBGRA[i].height=0) then continue;
51 while (TempBGRA[i].Width < NewWidth) or (TempBGRA[i].Height < NewHeight) do
52 BGRAReplace(TempBGRA[i], TempBGRA[i].FilterSmartZoom3(moLowSmooth));
53 BGRAReplace(TempBGRA[i], TempBGRA[i].Resample(NewWidth,NewHeight));
54 BGRAReplace(TempBGRA[i], TempBGRA[i].FilterSharpen(0.50));
55 end;
56 TempBmp.Free;
57
58 TargetList.Clear;
59 TargetList.Width:= NewWidth;
60 TargetList.Height:= NewHeight;
61
62 for i := 0 to high(TempBGRA) do
63 begin
64 {$IFDEF LCLWin32}
65 If TBGRAPixel_RGBAOrder then TempBGRA[i].SwapRedBlue;
66 {$ENDIF}
67 TargetList.Add(TempBGRA[i].Bitmap,nil);
68 TempBGRA[i].Free;
69 end;
70 end;
71
DoScaleXnull72 function DoScaleX(Size: Integer; FromDPI: Integer; ToDPI: Integer): integer;
73 begin
74 if ToDPI = 0 then ToDPI := ScreenInfo.PixelsPerInchX;
75 if ToDPI <= FromDPI then
76 result := Size
77 else
78 Result := MulDiv(Size, ToDPI, FromDPI);
79 end;
80
DoScaleYnull81 function DoScaleY(Size: Integer; FromDPI: Integer; ToDPI: Integer): integer;
82 begin
83 if ToDPI = 0 then ToDPI := ScreenInfo.PixelsPerInchY;
84 if ToDPI <= FromDPI then
85 result := Size
86 else
87 Result := MulDiv(Size, ToDPI, FromDPI);
88 end;
89
DoScaleXFnull90 function DoScaleXF(Size: single; FromDPI: Integer; ToDPI: Integer): single;
91 begin
92 if ToDPI = 0 then ToDPI := ScreenInfo.PixelsPerInchX;
93 if ToDPI <= FromDPI then
94 result := Size
95 else
96 Result := Size * ToDPI / FromDPI;
97 end;
98
DoScaleYFnull99 function DoScaleYF(Size: single; FromDPI: Integer; ToDPI: Integer): single;
100 begin
101 if ToDPI = 0 then ToDPI := ScreenInfo.PixelsPerInchY;
102 if ToDPI <= FromDPI then
103 result := Size
104 else
105 Result := Size * ToDPI / FromDPI;
106 end;
107
108 procedure ScaleControl(Control: TControl; FromDPI: Integer; ToDPI_X: Integer;
109 ToDPI_Y: Integer; ScaleToolbar: boolean);
110 var
111 n: Integer;
112 WinControl: TWinControl;
113 ToolBarControl: TToolBar;
114 begin
115 if ToDPI_X = 0 then ToDPI_X := ScreenInfo.PixelsPerInchX;
116 if ToDPI_Y = 0 then ToDPI_Y := ScreenInfo.PixelsPerInchY;
117 if ToDPI_X < FromDPI then ToDPI_X := FromDPI;
118 if ToDPI_Y < FromDPI then ToDPI_Y := FromDPI;
119 if (ToDPI_X = FromDPI) and (ToDPI_Y = FromDPI) then exit;
120
121 with Control do begin
122 Left:=DoScaleX(Left,FromDPI,ToDPI_X);
123 Top:=DoScaleY(Top,FromDPI,ToDPI_Y);
124 Width:=DoScaleX(Width,FromDPI,ToDPI_X);
125 Height:=DoScaleY(Height,FromDPI,ToDPI_Y);
126 if not IsParentFont then
127 begin
128 if Font.Size = 0 then
129 Font.Height := -DoScaleY(12,FromDPI,ToDPI_Y)
130 else
131 Font.Size:= round(Font.Size * ToDPI_Y / FromDPI);
132 end;
133 end;
134
135 if Control is TToolBar then begin
136 if not ScaleToolbar then exit;
137 ToolBarControl:=TToolBar(Control);
138 with ToolBarControl do begin
139 ButtonWidth:=DoScaleX(ButtonWidth,FromDPI,ToDPI_X);
140 ButtonHeight:=DoScaleY(ButtonHeight,FromDPI,ToDPI_Y);
141 end;
142 exit;
143 end;
144
145 if Control is TWinControl then begin
146 WinControl:=TWinControl(Control);
147 with WinControl.ChildSizing do
148 begin
149 HorizontalSpacing := DoScaleX(HorizontalSpacing, FromDPI, ToDPI_X);
150 LeftRightSpacing := DoScaleX(LeftRightSpacing, FromDPI, ToDPI_X);
151 TopBottomSpacing := DoScaleY(TopBottomSpacing, FromDPI, ToDPI_Y);
152 VerticalSpacing := DoScaleY(VerticalSpacing, FromDPI, ToDPI_Y);
153 end;
154 if WinControl.ControlCount > 0 then begin
155 for n:=0 to WinControl.ControlCount-1 do begin
156 if WinControl.Controls[n] is TControl then begin
157 ScaleControl(WinControl.Controls[n],FromDPI,ToDPI_X,ToDPI_Y,
158 ScaleToolbar);
159 end;
160 end;
161 end;
162 end;
163 end;
164
165 end.
166