source: trunk/Packages/Common/UScaleDPI.pas

Last change on this file was 38, checked in by chronos, 7 years ago
  • Modified: Updated Common package.
File size: 11.2 KB
Line 
1unit UScaleDPI;
2
3{ See: http://wiki.lazarus.freepascal.org/High_DPI }
4
5{$mode delphi}{$H+}
6
7interface
8
9uses
10 Classes, Forms, Graphics, Controls, ComCtrls, LCLType, SysUtils, StdCtrls,
11 Contnrs;
12
13type
14
15 { TControlDimension }
16
17 TControlDimension = class
18 BoundsRect: TRect;
19 FontHeight: Integer;
20 Controls: TObjectList; // TList<TControlDimension>
21 // Class specifics
22 ButtonSize: TPoint; // TToolBar
23 CoolBandWidth: Integer;
24 ConstraintsMin: TPoint; // TForm
25 ConstraintsMax: TPoint; // TForm
26 constructor Create;
27 destructor Destroy; override;
28 end;
29
30 { TScaleDPI }
31
32 TScaleDPI = class(TComponent)
33 private
34 FAutoDetect: Boolean;
35 FDesignDPI: TPoint;
36 FDPI: TPoint;
37 procedure SetAutoDetect(AValue: Boolean);
38 procedure SetDesignDPI(AValue: TPoint);
39 procedure SetDPI(AValue: TPoint);
40 public
41 procedure StoreDimensions(Control: TControl; Dimensions: TControlDimension);
42 procedure RestoreDimensions(Control: TControl; Dimensions: TControlDimension);
43 procedure ScaleDimensions(Control: TControl; Dimensions: TControlDimension);
44 procedure ApplyToAll(FromDPI: TPoint);
45 procedure ScaleControl(Control: TControl; FromDPI: TPoint);
46 procedure ScaleImageList(ImgList: TImageList; FromDPI: TPoint);
47 function ScalePoint(APoint: TPoint; FromDPI: TPoint): TPoint;
48 function ScaleRect(ARect: TRect; FromDPI: TPoint): TRect;
49 function ScaleX(Size: Integer; FromDPI: Integer): Integer;
50 function ScaleY(Size: Integer; FromDPI: Integer): Integer;
51 constructor Create(AOwner: TComponent); override;
52 property DesignDPI: TPoint read FDesignDPI write SetDesignDPI;
53 property DPI: TPoint read FDPI write SetDPI;
54 published
55 property AutoDetect: Boolean read FAutoDetect write SetAutoDetect;
56 end;
57
58procedure Register;
59
60
61implementation
62
63resourcestring
64 SWrongDPI = 'Wrong DPI [%d,%d]';
65
66procedure Register;
67begin
68 RegisterComponents('Common', [TScaleDPI]);
69end;
70
71{ TControlDimension }
72
73constructor TControlDimension.Create;
74begin
75 Controls := TObjectList.Create;
76end;
77
78destructor TControlDimension.Destroy;
79begin
80 FreeAndNil(Controls);
81 inherited Destroy;
82end;
83
84procedure TScaleDPI.SetAutoDetect(AValue: Boolean);
85begin
86 if FAutoDetect = AValue then Exit;
87 FAutoDetect := AValue;
88 if AValue then begin
89 DPI := Point(ScreenInfo.PixelsPerInchX, ScreenInfo.PixelsPerInchY);
90 end;
91end;
92
93procedure TScaleDPI.SetDesignDPI(AValue: TPoint);
94begin
95 if (FDesignDPI.X = AValue.X) and (FDesignDPI.Y = AValue.Y) then Exit;
96 if (AValue.X <= 0) or (AValue.Y <= 0) then
97 raise Exception.Create(Format(SWrongDPI, [AValue.X, AValue.Y]));
98 FDesignDPI := AValue;
99end;
100
101procedure TScaleDPI.SetDPI(AValue: TPoint);
102begin
103 if (FDPI.X = AValue.X) and (FDPI.Y = AValue.Y) then Exit;
104 if (AValue.X <= 0) or (AValue.Y <= 0) then
105 raise Exception.Create(Format(SWrongDPI, [AValue.X, AValue.Y]));
106 FDPI := AValue;
107end;
108
109procedure TScaleDPI.StoreDimensions(Control: TControl;
110 Dimensions: TControlDimension);
111var
112 NewControl: TControlDimension;
113 I: Integer;
114begin
115 Dimensions.BoundsRect := Control.BoundsRect;
116 Dimensions.FontHeight := Control.Font.GetTextHeight('Hg');
117 Dimensions.Controls.Clear;
118 if Control is TToolBar then
119 Dimensions.ButtonSize := Point(TToolBar(Control).ButtonWidth, TToolBar(Control).ButtonHeight);
120 if Control is TForm then begin
121 Dimensions.ConstraintsMin := Point(TForm(Control).Constraints.MinWidth,
122 TForm(Control).Constraints.MinHeight);
123 Dimensions.ConstraintsMax := Point(TForm(Control).Constraints.MaxWidth,
124 TForm(Control).Constraints.MaxHeight);
125 end;
126 if Control is TWinControl then
127 for I := 0 to TWinControl(Control).ControlCount - 1 do begin
128 if TWinControl(Control).Controls[I] is TControl then
129 // Do not scale docked forms twice
130 if not (TWinControl(Control).Controls[I] is TForm) then begin
131 NewControl := TControlDimension.Create;
132 Dimensions.Controls.Add(NewControl);
133 StoreDimensions(TWinControl(Control).Controls[I], NewControl);
134 end;
135 end;
136end;
137
138procedure TScaleDPI.RestoreDimensions(Control: TControl;
139 Dimensions: TControlDimension);
140var
141 I: Integer;
142begin
143 Control.BoundsRect := Dimensions.BoundsRect;
144 Control.Font.Height := Dimensions.FontHeight;
145 if Control is TToolBar then begin
146 TToolBar(Control).ButtonWidth := Dimensions.ButtonSize.X;
147 TToolBar(Control).ButtonHeight := Dimensions.ButtonSize.Y;
148 end;
149 if Control is TForm then begin
150 TForm(Control).Constraints.MinWidth := Dimensions.ConstraintsMin.X;
151 TForm(Control).Constraints.MinHeight := Dimensions.ConstraintsMin.Y;
152 TForm(Control).Constraints.MaxWidth := Dimensions.ConstraintsMax.X;
153 TForm(Control).Constraints.MaxHeight := Dimensions.ConstraintsMax.Y;
154 end;
155 if Control is TWinControl then
156 for I := 0 to TWinControl(Control).ControlCount - 1 do begin
157 if TWinControl(Control).Controls[I] is TControl then
158 // Do not scale docked forms twice
159 if not (TWinControl(Control).Controls[I] is TForm) then begin
160 RestoreDimensions(TWinControl(Control).Controls[I], TControlDimension(Dimensions.Controls[I]));
161 end;
162 end;
163end;
164
165procedure TScaleDPI.ScaleDimensions(Control: TControl;
166 Dimensions: TControlDimension);
167var
168 I: Integer;
169begin
170 Control.BoundsRect := ScaleRect(Dimensions.BoundsRect, DesignDPI);
171 Control.Font.Height := ScaleY(Dimensions.FontHeight, DesignDPI.Y);
172 if Control is TToolBar then begin
173 TToolBar(Control).ButtonWidth := ScaleX(Dimensions.ButtonSize.X, DesignDPI.X);
174 TToolBar(Control).ButtonHeight := ScaleY(Dimensions.ButtonSize.Y, DesignDPI.Y);
175 end;
176 if Control is TCoolBar then begin
177 with TCoolBar(Control) do
178 for I := 0 to Bands.Count - 1 do
179 with TCoolBand(Bands[I]) do begin
180 MinWidth := ScaleX(Dimensions.ButtonSize.X, DesignDPI.X);
181 MinHeight := ScaleY(Dimensions.ButtonSize.Y, DesignDPI.Y);
182 //Width := ScaleX(Dimensions.BoundsRect.Left -
183 end;
184 end;
185 if Control is TForm then begin
186 TForm(Control).Constraints.MinWidth := ScaleX(Dimensions.ConstraintsMin.X, DesignDPI.X);
187 TForm(Control).Constraints.MaxWidth := ScaleX(Dimensions.ConstraintsMax.X, DesignDPI.X);
188 TForm(Control).Constraints.MinHeight := ScaleY(Dimensions.ConstraintsMin.Y, DesignDPI.Y);
189 TForm(Control).Constraints.MaxHeight := ScaleY(Dimensions.ConstraintsMax.Y, DesignDPI.Y);
190 end;
191 if Control is TWinControl then
192 for I := 0 to TWinControl(Control).ControlCount - 1 do begin
193 if TWinControl(Control).Controls[I] is TControl then
194 // Do not scale docked forms twice
195 if not (TWinControl(Control).Controls[I] is TForm) then begin
196 ScaleDimensions(TWinControl(Control).Controls[I], TControlDimension(Dimensions.Controls[I]));
197 end;
198 end;
199end;
200
201procedure TScaleDPI.ApplyToAll(FromDPI: TPoint);
202var
203 I: Integer;
204begin
205 for I := 0 to Screen.FormCount - 1 do begin
206 ScaleControl(Screen.Forms[I], FromDPI);
207 end;
208end;
209
210procedure TScaleDPI.ScaleImageList(ImgList: TImageList; FromDPI: TPoint);
211var
212 TempBmp: TBitmap;
213 Temp: array of TBitmap;
214 NewWidth, NewHeight: integer;
215 I: Integer;
216begin
217 ImgList.BeginUpdate;
218 NewWidth := ScaleX(ImgList.Width, FromDPI.X);
219 NewHeight := ScaleY(ImgList.Height, FromDPI.Y);
220
221 SetLength(Temp, ImgList.Count);
222 for I := 0 to ImgList.Count - 1 do
223 begin
224 TempBmp := TBitmap.Create;
225 TempBmp.PixelFormat := pf32bit;
226 ImgList.GetBitmap(I, TempBmp);
227 Temp[I] := TBitmap.Create;
228 Temp[I].SetSize(NewWidth, NewHeight);
229 Temp[I].PixelFormat := pf32bit;
230 Temp[I].TransparentColor := TempBmp.TransparentColor;
231 //Temp[I].TransparentMode := TempBmp.TransparentMode;
232 Temp[I].Transparent := True;
233 Temp[I].Canvas.Brush.Style := bsSolid;
234 Temp[I].Canvas.Brush.Color := Temp[I].TransparentColor;
235 Temp[I].Canvas.FillRect(0, 0, Temp[I].Width, Temp[I].Height);
236
237 if (Temp[I].Width = 0) or (Temp[I].Height = 0) then Continue;
238 Temp[I].Canvas.StretchDraw(Rect(0, 0, Temp[I].Width, Temp[I].Height), TempBmp);
239 TempBmp.Free;
240 end;
241
242 ImgList.Clear;
243 ImgList.Width := NewWidth;
244 ImgList.Height := NewHeight;
245
246 for I := 0 to High(Temp) do
247 begin
248 ImgList.Add(Temp[I], nil);
249 Temp[i].Free;
250 end;
251 ImgList.EndUpdate;
252end;
253
254function TScaleDPI.ScaleX(Size: Integer; FromDPI: Integer): Integer;
255begin
256 Result := MulDiv(Size, DPI.X, FromDPI);
257end;
258
259function TScaleDPI.ScaleY(Size: Integer; FromDPI: Integer): Integer;
260begin
261 Result := MulDiv(Size, DPI.Y, FromDPI);
262end;
263
264function TScaleDPI.ScalePoint(APoint: TPoint; FromDPI: TPoint): TPoint;
265begin
266 Result.X := ScaleX(APoint.X, FromDPI.X);
267 Result.Y := ScaleY(APoint.Y, FromDPI.Y);
268end;
269
270function TScaleDPI.ScaleRect(ARect: TRect; FromDPI: TPoint): TRect;
271begin
272 Result.TopLeft := ScalePoint(ARect.TopLeft, FromDPI);
273 Result.BottomRight := ScalePoint(ARect.BottomRight, FromDPI);
274end;
275
276constructor TScaleDPI.Create(AOwner: TComponent);
277begin
278 inherited;
279 DPI := Point(96, 96);
280 DesignDPI := Point(96, 96);
281end;
282
283procedure TScaleDPI.ScaleControl(Control: TControl; FromDPI: TPoint);
284var
285 I: Integer;
286 WinControl: TWinControl;
287 ToolBarControl: TToolBar;
288 //OldAnchors: TAnchors;
289 //OldAutoSize: Boolean;
290begin
291 //if Control is TMemo then Exit;
292 //if Control is TForm then
293 // Control.DisableAutoSizing;
294 with Control do begin
295 //OldAutoSize := AutoSize;
296 //AutoSize := False;
297 //Anchors := [];
298 Left := ScaleX(Left, FromDPI.X);
299 Top := ScaleY(Top, FromDPI.Y);
300 //if not (akRight in Anchors) then
301 Width := ScaleX(Width, FromDPI.X);
302 //if not (akBottom in Anchors) then
303 Height := ScaleY(Height, FromDPI.Y);
304 {$IFDEF LCL Qt}
305 Font.Size := 0;
306 {$ELSE}
307 Font.Height := ScaleY(Font.GetTextHeight('Hg'), FromDPI.Y);
308 {$ENDIF}
309 //Anchors := OldAnchors;
310 //AutoSize := OldAutoSize;
311 end;
312
313 if Control is TCoolBar then
314 with TCoolBar(Control) do begin
315 BeginUpdate;
316 for I := 0 to Bands.Count - 1 do
317 with Bands[I] do begin
318 MinWidth := ScaleX(MinWidth, FromDPI.X);
319 MinHeight := ScaleY(MinHeight, FromDPI.Y);
320 // Workaround to bad band width auto sizing
321 //Width := ScaleX(Width, FromDPI.X);
322 Width := ScaleX(Control.Width + 28, FromDPI.X);
323 //Control.Invalidate;
324 end;
325 // Workaround for bad autosizing of coolbar
326 if AutoSize then begin
327 AutoSize := False;
328 Height := ScaleY(Height, FromDPI.Y);
329 AutoSize := True;
330 end;
331 EndUpdate;
332 end;
333
334 if Control is TToolBar then begin
335 ToolBarControl := TToolBar(Control);
336 with ToolBarControl do begin
337 ButtonWidth := ScaleX(ButtonWidth, FromDPI.X);
338 ButtonHeight := ScaleY(ButtonHeight, FromDPI.Y);
339 end;
340 end;
341
342 //if not (Control is TCustomPage) then
343 if Control is TWinControl then begin
344 WinControl := TWinControl(Control);
345 if WinControl.ControlCount > 0 then begin
346 for I := 0 to WinControl.ControlCount - 1 do begin
347 if WinControl.Controls[I] is TControl then begin
348 ScaleControl(WinControl.Controls[I], FromDPI);
349 end;
350 end;
351 end;
352 end;
353 //if Control is TForm then
354 // Control.EnableAutoSizing;
355end;
356
357end.
Note: See TracBrowser for help on using the repository browser.