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