1 // SPDX-License-Identifier: GPL-3.0-only
2 unit UZoom;
3
4 {$mode objfpc}{$H+}
5
6 interface
7
8 uses
9 Classes, SysUtils, Forms, StdCtrls, BGRABitmapTypes;
10
11 type
12 TZoom = class;
13
14 TOnZoomChangedHandler = procedure(sender: TZoom; ANewZoom: single) of object;
15
16 TCustomMainFormLayout = class
17 protected
GetWorkAreanull18 function GetWorkArea: TRect; virtual; abstract;
19 public
20 property WorkArea: TRect read GetWorkArea;
21 end;
22
23 { TZoom }
24
25 TZoom = class
26 private
27 FLayout: TCustomMainFormLayout;
28 FLabelCurrentZoom: TLabel;
29 FEditZoom: TEdit;
30 FMaxFactor: single;
31 FMinFactor: single;
32 FZoomFactor: single;
33 FOnZoomChangedHandler : TOnZoomChangedHandler;
34 FBitmapPosition: TPointF;
35 FMousePosition: TPoint;
GetEditingZoomnull36 function GetEditingZoom: boolean;
GetPositionDefinednull37 function GetPositionDefined: boolean;
GetZoomFactornull38 function GetZoomFactor: single;
39 procedure SetEditingZoom(AValue: boolean);
40 procedure SetMaxFactor(AValue: single);
41 procedure SetMinFactor(AValue: single);
42 procedure SetZoomFactor(AValue: single);
43 protected
44 procedure EditZoom_KeyPress(Sender: TObject; var Key: char);
45 procedure EditZoom_ZoomExit(Sender: TObject);
46 procedure LabelCurrentZoom_Click(Sender: TObject);
47 procedure UpdateLabel;
RoundZoomnull48 function RoundZoom(AValue: single): single;
49 public
50 constructor Create(ALabelCurrentZoom: TLabel; AEditZoom: TEdit);
51 destructor Destroy; override;
52 procedure ZoomOriginal;
53 procedure ZoomFit(AImageWidth,AImageHeight: integer);
54 procedure ZoomIn(AFine: boolean = false);
55 procedure ZoomOut(AFine: boolean = false);
56 procedure SetPosition(ABitmapPosition: TPointF; AMousePosition: TPoint);
57 procedure ClearPosition;
58 procedure DoAction(const AName: string);
GetScaledAreanull59 function GetScaledArea(const AWorkArea: TRect; AImageWidth, AImageHeight: integer; var AViewOffset: TPoint): TRect;
60 property Layout: TCustomMainFormLayout read FLayout write FLayout;
61 property EditingZoom: boolean read GetEditingZoom write SetEditingZoom;
62 property Factor: single read GetZoomFactor write SetZoomFactor;
63 property OnZoomChanged: TOnZoomChangedHandler read FOnZoomChangedHandler write FOnZoomChangedHandler;
64 property MaxFactor: single read FMaxFactor write SetMaxFactor;
65 property MinFactor: single read FMinFactor write SetMinFactor;
66 property BitmapPosition: TPointF read FBitmapPosition;
67 property MousePosition: TPoint read FMousePosition;
68 property PositionDefined: boolean read GetPositionDefined;
69 end;
70
71 implementation
72
73 uses Math, Dialogs, LazPaintType;
74
75 { TZoom }
76
TZoom.GetEditingZoomnull77 function TZoom.GetEditingZoom: boolean;
78 begin
79 result := FEditZoom.Visible;
80 end;
81
TZoom.GetPositionDefinednull82 function TZoom.GetPositionDefined: boolean;
83 begin
84 result := not isEmptyPointF(FBitmapPosition);
85 end;
86
GetZoomFactornull87 function TZoom.GetZoomFactor: single;
88 begin
89 result := FZoomFactor;
90 end;
91
92 procedure TZoom.SetEditingZoom(AValue: boolean);
93 begin
94 if AValue <> FEditZoom.Visible then
95 begin
96 if AValue then
97 begin
98 FEditZoom.Text := IntToStr(round(FZoomFactor*100));
99 FEditZoom.Visible := true;
100 FLabelCurrentZoom.Visible := false;
101 SafeSetFocus(FEditZoom);
102 end else
103 begin
104 FLabelCurrentZoom.Visible := not AValue;
105 FEditZoom.Visible := AValue
106 end;
107 end;
108 end;
109
110 procedure TZoom.SetMaxFactor(AValue: single);
111 begin
112 if FMaxFactor=AValue then Exit;
113 FMaxFactor:=AValue;
114 end;
115
116 procedure TZoom.SetMinFactor(AValue: single);
117 begin
118 if FMinFactor=AValue then Exit;
119 FMinFactor:=AValue;
120 end;
121
122 procedure TZoom.SetZoomFactor(AValue: single);
123 begin
124 if (FMinFactor <> 0) and (AValue < FMinFactor) then AValue := FMinFactor;
125 if (FMaxFactor <> 0) and (AValue > FMaxFactor) then AValue := FMaxFactor;
126 if AValue = FZoomFactor then exit;
127 EditingZoom:= False;
128 FZoomFactor:= AValue;
129 if Assigned(FOnZoomChangedHandler) then
130 FOnZoomChangedHandler(self, AValue);
131 UpdateLabel;
132 end;
133
134 procedure TZoom.EditZoom_ZoomExit(Sender: TObject);
135 begin
136 EditingZoom:= false;
137 end;
138
139 procedure TZoom.LabelCurrentZoom_Click(Sender: TObject);
140 begin
141 EditingZoom := true;
142 end;
143
144 procedure TZoom.UpdateLabel;
145 begin
146 if Factor < 3 then
147 FLabelCurrentZoom.Caption := inttostr(round(Factor*100))+'%' else
148 FLabelCurrentZoom.Caption := 'x'+FloatToStr(round(Factor*100)/100);
149 end;
150
TZoom.RoundZoomnull151 function TZoom.RoundZoom(AValue: single): single;
152 var zoomFactorLog,halfZoom,sign: single;
153 begin
154 halfZoom := ln(1.5)/ln(2);
155 zoomFactorLog := ln(AValue)/ln(2);
156 if zoomFactorLog < 0 then
157 begin
158 sign := -1;
159 zoomFactorLog:= -zoomFactorLog;
160 end else
161 sign := 1;
162 if frac(zoomFactorLog) >= (halfZoom+1)/2 then
163 zoomFactorLog:= ceil(zoomFactorLog)
164 else
165 if frac(zoomFactorLog) >= halfZoom/2 then
166 zoomFactorLog:= floor(zoomFactorLog)+halfZoom
167 else
168 zoomFactorLog:= floor(zoomFactorLog);
169
170 result := exp(sign*zoomFactorLog*ln(2));
171 end;
172
173 procedure TZoom.EditZoom_KeyPress(Sender: TObject; var Key: char);
174 begin
175 if Key = #13 then
176 begin
177 Key := #0;
178 EditingZoom:= false;
179 if length(FEditZoom.Text) > 0 then
180 begin
181 try
182 Factor:= StrToInt(FEditZoom.Text)/100;
183 except
184 on ex:exception do
185 begin end;
186 end;
187 end;
188 end else
189 if Key = #27 then
190 begin
191 Key := #0;
192 EditingZoom := false;
193 end else
194 if not (Key in['0'..'9',#8]) then Key := #0;
195 end;
196
197 constructor TZoom.Create(ALabelCurrentZoom: TLabel; AEditZoom: TEdit);
198 begin
199 inherited Create;
200 FLayout := nil;
201 FLabelCurrentZoom := ALabelCurrentZoom;
202 FLabelCurrentZoom.OnClick := @LabelCurrentZoom_Click;
203 FEditZoom := AEditZoom;
204 FEditZoom.Top := FLabelCurrentZoom.Top-1;
205 FEditZoom.OnExit := @EditZoom_ZoomExit;
206 FEditZoom.OnKeyPress:= @EditZoom_KeyPress;
207 FZoomFactor:= 1;
208 FMinFactor := 0;
209 FMaxFactor := 0;
210 ClearPosition;
211 UpdateLabel;
212 end;
213
214 destructor TZoom.Destroy;
215 begin
216 FLabelCurrentZoom.OnClick := nil;
217 FEditZoom.OnExit := nil;
218 FEditZoom.OnKeyPress := nil;
219 inherited Destroy;
220 end;
221
222 procedure TZoom.ZoomOriginal;
223 begin
224 Factor := 1;
225 end;
226
227 procedure TZoom.ZoomFit(AImageWidth, AImageHeight: integer);
228 const pixelMargin = 0;
229 var zx,zy: single;
230 pictureArea: TRect;
231 begin
232 if FLayout = nil then exit;
233 pictureArea := FLayout.WorkArea;
234 if (AImageWidth = 0) or (AImageHeight = 0) or (pictureArea.right-pictureArea.Left <= pixelMargin)
235 or (pictureArea.Bottom-pictureArea.top <= pixelMargin) then exit;
236 try
237 zx := (pictureArea.right-pictureArea.left-pixelMargin)/AImageWidth;
238 zy := (pictureArea.bottom-pictureArea.top-pixelMargin)/AImageheight;
239 Factor:= min(zx,zy);
240 except
241 on ex:Exception do
242 begin end;
243 end;
244 end;
245
246 procedure TZoom.ZoomIn(AFine: boolean);
247 begin
248 if AFine then
249 Factor := Factor*1.1
250 else if RoundZoom(Factor) > Factor then
251 Factor := RoundZoom(Factor)
252 else
253 Factor := RoundZoom(Factor*sqrt(2));
254 end;
255
256 procedure TZoom.ZoomOut(AFine: boolean);
257 begin
258 if AFine then
259 Factor := Factor/1.1
260 else if RoundZoom(Factor) < Factor then
261 Factor := RoundZoom(Factor)
262 else
263 Factor := RoundZoom(Factor/sqrt(2));
264 end;
265
266 procedure TZoom.SetPosition(ABitmapPosition: TPointF; AMousePosition: TPoint);
267 begin
268 FBitmapPosition := ABitmapPosition;
269 FMousePosition := AMousePosition;
270 end;
271
272 procedure TZoom.ClearPosition;
273 begin
274 SetPosition(EmptyPointF,Point(0,0));
275 end;
276
277 procedure TZoom.DoAction(const AName: string);
278 begin
279 if AName = 'ViewZoomIn' then ZoomIn else
280 if AName = 'ViewZoomOriginal' then ZoomOriginal else
281 if AName = 'ViewZoomOut' then ZoomOut;
282 end;
283
TZoom.GetScaledAreanull284 function TZoom.GetScaledArea(const AWorkArea: TRect; AImageWidth, AImageHeight: integer; var AViewOffset: TPoint): TRect;
285 var
286 scaledWidth,scaledHeight: integer;
287 maxOffset, minOffset: TPoint;
288 temp: integer;
289 begin
290 scaledWidth := round(AImageWidth*Factor);
291 if scaledWidth = 0 then scaledWidth := 1;
292 scaledHeight := round(AImageHeight*Factor);
293 if scaledHeight = 0 then scaledHeight := 1;
294 result.Left := (AWorkArea.Left+AWorkArea.Right-scaledWidth) div 2;
295 result.Top := (AWorkArea.Top+AWorkArea.Bottom-scaledHeight) div 2;
296
297 maxOffset := point(floor((AWorkArea.Right-(result.Left+scaledWidth))/Factor),
298 floor((AWorkArea.Bottom-(result.Top+scaledHeight))/Factor));
299 minOffset := point(ceil((AWorkArea.Left-result.Left)/Factor),
300 ceil((AWorkArea.Top-result.Top)/Factor));
301 if maxOffset.X < minOffset.X then
302 begin
303 temp := maxOffset.X;
304 maxOffset.X := minOffset.X;
305 minOffset.X := temp;
306 end;
307 if maxOffset.Y < minOffset.Y then
308 begin
309 temp := maxOffset.Y;
310 maxOffset.Y := minOffset.Y;
311 minOffset.Y := temp;
312 end;
313
314 if minOffset.X > -AImageWidth div 2 then minOffset.X := -AImageWidth div 2;
315 if minOffset.Y > -AImageHeight div 2 then minOffset.Y := -AImageHeight div 2;
316 if maxOffset.X < AImageWidth div 2 then maxOffset.X := AImageWidth div 2;
317 if maxOffset.Y < AImageHeight div 2 then maxOffset.Y := AImageHeight div 2;
318
319 if AViewOffset.X < minOffset.X then AViewOffset.X := minOffset.X else
320 if AViewOffset.X > maxOffset.X then AViewOffset.X := maxOffset.X;
321
322 if AViewOffset.Y < minOffset.Y then AViewOffset.Y := minOffset.Y else
323 if AViewOffset.Y > maxOffset.Y then AViewOffset.Y := maxOffset.Y;
324
325 if AImageWidth <> 0 then result.Left += round(AViewOffset.X*scaledWidth/AImageWidth);
326 if AImageHeight <> 0 then result.Top += round(AViewOffset.Y*scaledHeight/AImageHeight);
327 result.Right := result.Left + scaledWidth;
328 result.Bottom := result.Top + scaledHeight;
329 end;
330
331 end.
332
333