1 {
2 Copyright (C) Alexey Torgashin, uvviewsoft.com
3 License: MPL 2.0 or LGPL
4 }
5
6 unit ATGauge;
7
8 {$ifdef FPC}
9 {$mode objfpc}{$H+}
10 {$endif}
11
12 interface
13
14 uses
15 Classes, SysUtils, Graphics, Controls,
16 Math, Types,
17 {$ifdef FPC}
18 InterfaceBase,
19 LCLType, LCLIntf,
20 {$endif}
21 ATCanvasPrimitives,
22 ATFlatThemes;
23
24 type
25 TATGaugeKind = (
26 gkText,
27 gkHorizontalBar,
28 gkVerticalBar,
29 gkPie,
30 gkNeedle,
31 gkHalfPie
32 );
33
34 type
35 { TATGauge }
36
37 TATGauge = class(TGraphicControl)
38 private
39 FDoubleBuffered: boolean;
40 FBitmap: TBitmap;
41 {$ifdef FPC}
42 FBorderStyle: TBorderStyle;
43 {$endif}
44 FKind: TATGaugeKind;
45 FMinValue: integer;
46 FMaxValue: integer;
47 FProgress: integer;
48 FShowText: boolean;
49 FShowTextInverted: boolean;
50 FTheme: PATFlatTheme;
51 procedure DoPaintTextInverted(C: TCanvas; r: TRect; const Str: string);
52 procedure DoPaintTextUsual(C: TCanvas; r: TRect; const Str: string);
53 procedure DoPaintTo(C: TCanvas; r: TRect);
GetPercentDonenull54 function GetPercentDone: integer;
GetPartDoneFloatnull55 function GetPartDoneFloat: Double;
56 {$ifdef FPC}
57 procedure SetBorderStyle(AValue: TBorderStyle);
58 {$endif}
59 procedure SetKind(AValue: TATGaugeKind);
60 procedure SetMaxValue(AValue: integer);
61 procedure SetMinValue(AValue: integer);
62 procedure SetProgress(AValue: integer);
63 procedure SetShowText(AValue: boolean);
64 procedure SetShowTextInverted(AValue: boolean);
65 protected
66 procedure Paint; override;
67 {$ifdef FPC}
68 procedure DoOnResize; override;
69 {$endif}
70 public
71 constructor Create(AOwner: TComponent); override;
72 destructor Destroy; override;
73 procedure AddProgress(AValue: integer);
74 property PercentDone: integer read GetPercentDone;
75 property Theme: PATFlatTheme read FTheme write FTheme;
76 published
77 property Align;
78 property Anchors;
79 {$ifdef FPC}
80 property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
81 property BorderSpacing;
82 {$endif}
83 property Color;
84 property Constraints;
85 property DoubleBuffered: boolean read FDoubleBuffered write FDoubleBuffered;
86 property ParentColor;
87 property ParentShowHint;
88 property PopupMenu;
89 property ShowHint;
90 property Kind: TATGaugeKind read FKind write SetKind default gkHorizontalBar;
91 property Progress: integer read FProgress write SetProgress default 0;
92 property MinValue: integer read FMinValue write SetMinValue default 0;
93 property MaxValue: integer read FMaxValue write SetMaxValue default 100;
94 property ShowText: boolean read FShowText write SetShowText default true;
95 property ShowTextInverted: boolean read FShowTextInverted write SetShowTextInverted default false;
96 property OnClick;
97 property OnDblClick;
98 property OnResize;
99 property OnContextPopup;
100 property OnMouseDown;
101 property OnMouseUp;
102 property OnMouseMove;
103 property OnMouseEnter;
104 property OnMouseLeave;
105 property OnMouseWheel;
106 property OnMouseWheelDown;
107 property OnMouseWheelUp;
108 end;
109
110 implementation
111
IsDoubleBufferedNeedednull112 function IsDoubleBufferedNeeded: boolean;
113 begin
114 Result:= true;
115 {$ifdef FPC}
116 Result:= WidgetSet.GetLCLCapability(lcCanDrawOutsideOnPaint) = LCL_CAPABILITY_YES;
117 {$endif}
118 end;
119
120 { TATGauge }
121
122 procedure TATGauge.DoPaintTextUsual(C: TCanvas; r: TRect; const Str: string);
123 var
124 StrSize: TSize;
125 begin
126 StrSize:= C.TextExtent(Str);
127 C.Font.Name:= Theme^.FontName;
128 C.Font.Size:= Theme^.DoScaleFont(Theme^.FontSize);
129 C.Brush.Style:= bsClear;
130 C.TextOut(
131 (r.Left+r.Right-StrSize.cx) div 2,
132 (r.Top+r.Bottom-StrSize.cy) div 2,
133 Str);
134 C.Brush.Style:= bsSolid;
135 end;
136
137 procedure TATGauge.DoPaintTextInverted(C: TCanvas; r: TRect; const Str: string);
138 const
139 ColorEmpty = clBlack;
140 var
141 StrSize: TSize;
142 Bmp: TBitmap;
143 Pnt: TPoint;
144 begin
145 StrSize:= C.TextExtent(Str);
146
147 Bmp:= TBitmap.Create;
148 try
149 Bmp.PixelFormat:= pf24bit;
150 BitmapResize(Bmp, StrSize.cx, StrSize.cy);
151 Bmp.Transparent:= true;
152 Bmp.TransparentColor:= ColorEmpty;
153
154 Bmp.Canvas.Brush.Color:= ColorEmpty;
155 Bmp.Canvas.FillRect(Rect(0, 0, Bmp.Width, Bmp.Height));
156
157 Bmp.Canvas.Font.Name:= Theme^.FontName;
158 Bmp.Canvas.Font.Size:= Theme^.DoScaleFont(Theme^.FontSize);
159 Bmp.Canvas.Font.Color:= Theme^.ColorFont;
160 Bmp.Canvas.Font.Quality:= fqNonAntialiased; //antialias
161 {$ifdef FPC}
162 Bmp.Canvas.AntialiasingMode:= amOn; //antialias
163 {$endif}
164 Bmp.Canvas.TextOut(0, 0, Str);
165
166 Pnt.X:= (r.Left+r.Right-StrSize.cx) div 2;
167 Pnt.Y:= (r.Top+r.Bottom-StrSize.cy) div 2;
168
169 C.CopyMode:= cmSrcInvert;
170 C.CopyRect(
171 Rect(Pnt.X, Pnt.Y, Pnt.X+StrSize.cx, Pnt.Y+StrSize.cy),
172 Bmp.Canvas,
173 Rect(0, 0, StrSize.cx, StrSize.cy));
174 C.CopyMode:= cmSrcCopy;
175 finally
176 Bmp.Free;
177 end;
178 end;
179
180 procedure TATGauge.DoPaintTo(C: TCanvas; r: TRect);
181 //
182 procedure DoFillBG(AColor: TColor);
183 begin
184 C.Pen.Color:= AColor;
185 C.Brush.Color:= AColor;
186 C.FillRect(r);
187 end;
188 //
189 var
190 NSize: integer;
191 Alfa: double;
192 Str: string;
193 r2: TRect;
194 begin
195 case FKind of
196 gkText:
197 begin
198 DoFillBG(Theme^.ColorBgPassive);
199 end;
200
201 gkHorizontalBar:
202 begin
203 DoFillBG(Theme^.ColorBgPassive);
204
205 C.Brush.Color:= Theme^.ColorBgOver;
206 NSize:= Round((r.Right-r.Left) * GetPartDoneFloat);
207 C.FillRect(Rect(r.Left, r.Top, r.Left+NSize, r.Bottom));
208 end;
209
210 gkVerticalBar:
211 begin
212 DoFillBG(Theme^.ColorBgPassive);
213
214 C.Brush.Color:= Theme^.ColorBgOver;
215 NSize:= Round((r.Bottom-r.Top) * GetPartDoneFloat);
216 C.FillRect(Rect(r.Left, r.Bottom-NSize, r.Right, r.Bottom));
217 end;
218
219 gkNeedle,
220 gkHalfPie:
221 begin
222 DoFillBG(Color);
223
224
225
226 {$ifdef FPC}
227 if FBorderStyle<>bsNone then NSize:= 1 else NSize:= 0;
228 {$else}
229 NSize:= 0;
230 {$endif}
231 r2:= Rect(
232 r.Left+NSize, r.Top+NSize,
233 r.Right-1-NSize, r.Bottom-1+(r.Bottom-r.Top)-NSize);
234
235 C.Pen.Color:= Theme^.ColorBgOver;
236 C.Brush.Color:= Theme^.ColorBgPassive;
237 C.Pie(r2.Left, r2.Top, r2.Right, r2.Bottom,
238 r.Right, r.Bottom,
239 r.Left, r.Bottom);
240
241 if FKind=gkHalfPie then
242 C.Brush.Color:= Theme^.ColorBgOver;
243
244 Alfa:= pi*GetPartDoneFloat;
245 C.Pie(r2.Left, r2.Top, r2.Right, r2.Bottom,
246 r2.Left-Round(1000*cos(Alfa)),
247 r2.Bottom-Round(1000*sin(Alfa)),
248 r2.Left,
249 r2.Bottom);
250
251 C.Pen.Color:= Theme^.ColorBgOver;
252 C.MoveTo(r2.Left, r.Bottom-1-NSize);
253 C.LineTo(r2.Right, r.Bottom-1-NSize);
254 end;
255
256 gkPie:
257 begin
258 DoFillBG(Color);
259
260 {$ifdef FPC}
261 if FBorderStyle<>bsNone then NSize:= 1 else NSize:= 0;
262 {$else}
263 NSize:= 0;
264 {$endif}
265 r2:= Rect(r.Left+NSize, r.Top+NSize, r.Right-NSize, r.Bottom-NSize);
266
267 C.Pen.Color:= Theme^.ColorBgOver;
268 C.Brush.Color:= Theme^.ColorBgPassive;
269 C.Ellipse(r2);
270
271 if FProgress>FMinValue then
272 begin
273 Alfa:= 2*pi*GetPartDoneFloat;
274 C.Pen.Color:= Theme^.ColorBgOver;
275 C.Brush.Color:= Theme^.ColorBgOver;
276
277 C.Pie(r2.Left, r2.Top, r2.Right, r2.Bottom,
278 (r2.Left+r2.Right) div 2 + Round(1000*sin(Alfa)),
279 (r2.Top+r2.Bottom) div 2 - Round(1000*cos(Alfa)),
280 (r2.Left+r2.Right) div 2,
281 r.Top
282 );
283 end;
284 end;
285 end;
286
287 //paint text
288 if FShowText then
289 begin
290 Str:= IntToStr(PercentDone)+'%';
291 if FShowTextInverted then
292 DoPaintTextInverted(C, r, Str)
293 else
294 DoPaintTextUsual(C, r, Str);
295 end;
296
297 //paint border
298 {$ifdef FPC}
299 if FBorderStyle<>bsNone then
300 begin
301 C.Pen.Color:= Theme^.ColorBorderPassive;
302 C.Brush.Style:= bsClear;
303 C.Rectangle(r);
304 C.Brush.Style:= bsSolid;
305 end;
306 {$endif}
307
308 end;
309
GetPartDoneFloatnull310 function TATGauge.GetPartDoneFloat: Double;
311 begin
312 Result:= (FProgress-FMinValue) / (FMaxValue-FMinValue);
313 end;
314
GetPercentDonenull315 function TATGauge.GetPercentDone: integer;
316 begin
317 Result:= Round(100 * GetPartDoneFloat);
318 end;
319
320 {$ifdef FPC}
321 procedure TATGauge.SetBorderStyle(AValue: TBorderStyle);
322 begin
323 if FBorderStyle=AValue then Exit;
324 FBorderStyle:=AValue;
325 Invalidate;
326 end;
327 {$endif}
328
329 procedure TATGauge.SetKind(AValue: TATGaugeKind);
330 begin
331 if FKind=AValue then Exit;
332 FKind:=AValue;
333 Invalidate;
334 end;
335
336 procedure TATGauge.SetMaxValue(AValue: integer);
337 begin
338 if FMaxValue=AValue then Exit;
339 FMaxValue:=Max(FMinValue+1, AValue);
340 FProgress:=Min(FProgress, FMaxValue);
341 Invalidate;
342 end;
343
344 procedure TATGauge.SetMinValue(AValue: integer);
345 begin
346 if FMinValue=AValue then Exit;
347 FMinValue:=Min(FMaxValue-1, AValue);
348 FProgress:=Max(FProgress, FMinValue);
349 Invalidate;
350 end;
351
352 procedure TATGauge.SetProgress(AValue: integer);
353 begin
354 if FProgress=AValue then Exit;
355 FProgress:=Max(FMinValue, Min(FMaxValue, AValue));
356 Invalidate;
357 end;
358
359 procedure TATGauge.SetShowText(AValue: boolean);
360 begin
361 if FShowText=AValue then Exit;
362 FShowText:=AValue;
363 Invalidate;
364 end;
365
366 procedure TATGauge.SetShowTextInverted(AValue: boolean);
367 begin
368 if FShowTextInverted=AValue then Exit;
369 FShowTextInverted:=AValue;
370 Invalidate;
371 end;
372
373 procedure TATGauge.Paint;
374 var
375 R: TRect;
376 begin
377 inherited;
378
379 R:= ClientRect;
380 if DoubleBuffered then
381 begin
382 FBitmap.Canvas.Font.Name:= Theme^.FontName;
383 FBitmap.Canvas.Font.Size:= Theme^.DoScaleFont(Theme^.FontSize);
384 FBitmap.Canvas.Font.Color:= Theme^.ColorFont;
385 DoPaintTo(FBitmap.Canvas, R);
386 Canvas.CopyRect(R, FBitmap.Canvas, R);
387 end
388 else
389 DoPaintTo(Canvas, R);
390 end;
391
392
393 constructor TATGauge.Create(AOwner: TComponent);
394 begin
395 inherited;
396
397 ControlStyle:= ControlStyle
398 +[csOpaque {$ifdef FPC}, csNoFocus{$endif}]
399 -[csDoubleClicks {$ifdef FPC},csTripleClicks{$endif}];
400
401 Width:= 150;
402 Height:= 50;
403 Color:= clBtnFace;
404
405 FBitmap:= TBitmap.Create;
406 FBitmap.PixelFormat:= pf24bit;
407 BitmapResize(FBitmap, 500, 80);
408
409 FDoubleBuffered:= IsDoubleBufferedNeeded;
410 FKind:= gkHorizontalBar;
411 {$ifdef FPC}
412 FBorderStyle:= bsSingle;
413 {$endif}
414
415 FMinValue:= 0;
416 FMaxValue:= 100;
417 FProgress:= 0;
418 FShowText:= true;
419 FShowTextInverted:= false;
420 FTheme:= @ATFlatTheme;
421 end;
422
423 destructor TATGauge.Destroy;
424 begin
425 FreeAndNil(FBitmap);
426 inherited;
427 end;
428
429 procedure TATGauge.AddProgress(AValue: integer);
430 begin
431 Progress:= Progress+AValue;
432 end;
433
434 {$ifdef FPC}
435 procedure TATGauge.DoOnResize;
436 begin
437 inherited;
438
439 if DoubleBuffered then
440 if Assigned(FBitmap) then
441 BitmapResizeBySteps(FBitmap, Width, Height);
442
443 Invalidate;
444 end;
445 {$endif}
446
447
448 end.
449
450