1 // SPDX-License-Identifier: LGPL-3.0-only (modified to allow linking)
2 {******************************* CONTRIBUTOR(S) ******************************
3 - Edivando S. Santos Brasil | mailedivando@gmail.com
4   (Compatibility with delphi VCL 11/2018)
5 
6 ***************************** END CONTRIBUTOR(S) *****************************}
7 unit BCRadialProgressBar;
8 
9 {$I bgracontrols.inc}
10 
11 interface
12 
13 uses
14   Classes, SysUtils, {$IFDEF FPC}LResources,{$ENDIF} Forms, Controls, Graphics, Dialogs, BCBaseCtrls,
15   {$IFNDEF FPC}Types, BGRAGraphics, GraphType, FPImage, {$ENDIF}
16   BGRABitmap, BGRABitmapTypes, BGRATextFX;
17 
18 type
19 
20   { TBCRadialProgressBar }
21 
22   TBCRadialProgressBar = class(TBCGraphicControl)
23   private
24     { Private declarations }
25     FMaxValue: integer;
26     FMinValue: integer;
27     FValue: integer;
28     FBitmap: TBGRABitmap;
29     FLineColor: TColor;
30     FLineBkgColor: TColor;
31     FFontShadowColor: TColor;
32     FFontShadowOffsetX: integer;
33     FFontShadowOffsetY: integer;
34     FFontShadowRadius: integer;
35     FLineWidth: single;
36     procedure SetFFontShadowColor(AValue: TColor);
37     procedure SetFFontShadowOffsetX(AValue: integer);
38     procedure SetFFontShadowOffsetY(AValue: integer);
39     procedure SetFFontShadowRadius(AValue: integer);
40     procedure SetFLineBkgColor(AValue: TColor);
41     procedure SetFLineColor(AValue: TColor);
42     procedure SetMaxValue(AValue: integer);
43     procedure SetMinValue(AValue: integer);
44     procedure SetValue(AValue: integer);
45     procedure SetLineWidth(AValue: single);
46   protected
47     { Protected declarations }
48     procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
49       {%H-}WithThemeSpace: boolean); override;
50     procedure DrawControl; override;
51     procedure RenderControl; override;
52     procedure SetColor(Value: TColor); override;
53   public
54     { Public declarations }
55     constructor Create(AOwner: TComponent); override;
56     destructor Destroy; override;
57   published
58     { Published declarations }
59     property Align;
60     property Anchors;
61     property MinValue: integer read FMinValue write SetMinValue default 0;
62     property MaxValue: integer read FMaxValue write SetMaxValue default 100;
63     property Value: integer read FValue write SetValue default 0;
64     property OnClick;
65     property OnMouseDown;
66     property OnMouseEnter;
67     property OnMouseLeave;
68     property OnMouseMove;
69     property OnMouseUp;
70     property OnMouseWheel;
71     property OnMouseWheelUp;
72     property OnMouseWheelDown;
73     property Color default clWhite;
74     property LineColor: TColor read FLineColor write SetFLineColor default clBlack;
75     property LineBkgColor: TColor read FLineBkgColor write SetFLineBkgColor default
76       clSilver;
77     property LineWidth: single read FLineWidth write SetLineWidth {$IFDEF FPC}default 4{$ENDIF};
78     property FontShadowColor: TColor read FFontShadowColor
79       write SetFFontShadowColor default clBlack;
80     property FontShadowOffsetX: integer read FFontShadowOffsetX
81       write SetFFontShadowOffsetX default 2;
82     property FontShadowOffsetY: integer read FFontShadowOffsetY
83       write SetFFontShadowOffsetY default 2;
84     property FontShadowRadius: integer read FFontSHadowRadius
85       write SetFFontShadowRadius default 4;
86     property Font;
87   end;
88 
89 {$IFDEF FPC}procedure Register;{$ENDIF}
90 
91 implementation
92 
93 {$IFDEF FPC}
94 procedure Register;
95 begin
96   {$IFDEF FPC}
97   {$I icons\bcradialprogressbar_icon.lrs}
98   {$ENDIF}
99   RegisterComponents('BGRA Controls', [TBCRadialProgressBar]);
100 end;
101 {$ENDIF}
102 
103 { TBCRadialProgressBar }
104 
105 procedure TBCRadialProgressBar.SetMaxValue(AValue: integer);
106 begin
107   if FMaxValue = AValue then
108     exit;
109   FMaxValue := AValue;
110   if FValue > FMaxValue then
111     FValue := FMaxValue;
112   if FMinValue > FMaxValue then
113     FMinValue := FMaxValue;
114   RenderControl;
115   Invalidate;
116 end;
117 
118 procedure TBCRadialProgressBar.SetFLineBkgColor(AValue: TColor);
119 begin
120   if FLineBkgColor = AValue then
121     Exit;
122   FLineBkgColor := AValue;
123   RenderControl;
124   Invalidate;
125 end;
126 
127 procedure TBCRadialProgressBar.SetFFontShadowColor(AValue: TColor);
128 begin
129   if FFontShadowColor = AValue then
130     Exit;
131   FFontShadowColor := AValue;
132   RenderControl;
133   Invalidate;
134 end;
135 
136 procedure TBCRadialProgressBar.SetFFontShadowOffsetX(AValue: integer);
137 begin
138   if FFontShadowOffsetX = AValue then
139     Exit;
140   FFontShadowOffsetX := AValue;
141   RenderControl;
142   Invalidate;
143 end;
144 
145 procedure TBCRadialProgressBar.SetFFontShadowOffsetY(AValue: integer);
146 begin
147   if FFontShadowOffsetY = AValue then
148     Exit;
149   FFontShadowOffsetY := AValue;
150   RenderControl;
151   Invalidate;
152 end;
153 
154 procedure TBCRadialProgressBar.SetFFontShadowRadius(AValue: integer);
155 begin
156   if FFontSHadowRadius = AValue then
157     Exit;
158   FFontSHadowRadius := AValue;
159   RenderControl;
160   Invalidate;
161 end;
162 
163 procedure TBCRadialProgressBar.SetFLineColor(AValue: TColor);
164 begin
165   if FLineColor = AValue then
166     Exit;
167   FLineColor := AValue;
168   RenderControl;
169   Invalidate;
170 end;
171 
172 procedure TBCRadialProgressBar.SetMinValue(AValue: integer);
173 begin
174   if FMinValue = AValue then
175     exit;
176   FMinValue := AValue;
177   if FValue < FMinValue then
178     FValue := FMinValue;
179   if FMaxValue < FMinValue then
180     FMaxValue := FMinValue;
181   RenderControl;
182   Invalidate;
183 end;
184 
185 procedure TBCRadialProgressBar.SetValue(AValue: integer);
186 begin
187   if FValue = AValue then
188     exit;
189   FValue := AValue;
190   if FValue < FMinValue then
191     FValue := FMinValue;
192   if FValue > FMaxValue then
193     FValue := FMaxValue;
194   RenderControl;
195   Invalidate;
196 end;
197 
198 procedure TBCRadialProgressBar.SetLineWidth(AValue: single);
199 begin
200   if (FLineWidth = AValue) then
201     exit;
202   FLineWidth := AValue;
203   RenderControl;
204   Invalidate;
205 end;
206 
207 procedure TBCRadialProgressBar.CalculatePreferredSize(
208   var PreferredWidth, PreferredHeight: integer; WithThemeSpace: boolean);
209 begin
210   PreferredWidth := 200;
211   PreferredHeight := 200;
212 end;
213 
214 procedure TBCRadialProgressBar.DrawControl;
215 begin
216   {$IFNDEF FPC}//# //@  IN DELPHI RenderControl NEDD. IF NO RenderControl BE BLACK AFTER INVALIDATE.
217   RenderControl;
218   {$ENDIF}
219   FBitmap.Draw(Canvas, 0, 0, False);
220 end;
221 
222 procedure TBCRadialProgressBar.RenderControl;
223 var
224   textBmp: TBGRABitmap;
225   textStr: string;
226   EffectiveLineWidth:single;
227 begin
228   FreeAndNil(FBitmap);
229   FBitmap := TBGRABitmap.Create(Width, Height);
230 
231   FBitmap.Canvas2D.beginPath;
232   FBitmap.Canvas2D.arc(Width / 2, Height / 2, Height / 2.5, 0, pi * 2, False);
233   FBitmap.Canvas2D.fillStyle(Color);
234   FBitmap.Canvas2D.fill;
235 
236   if LineWidth=0 then
237     EffectiveLineWidth:=Height / 50
238   else
239     EffectiveLineWidth:=LineWidth;
240 
241   FBitmap.Canvas2D.lineWidth := EffectiveLineWidth;
242   FBitmap.Canvas2D.strokeStyle(LineBkgColor);
243   FBitmap.Canvas2D.stroke;
244 
245   FBitmap.Canvas2D.beginPath;
246   if Value <> MinValue then
247     FBitmap.Canvas2D.arc(Width / 2, Height / 2, Height / 2.5, pi * 1.5,
248       (pi * 1.5) + ((pi * 2) * Value / MaxValue), False);
249   FBitmap.Canvas2D.fillStyle(BGRAPixelTransparent);
250   FBitmap.Canvas2D.fill;
251 
252   FBitmap.Canvas2D.lineWidth := EffectiveLineWidth;
253   FBitmap.Canvas2D.strokeStyle(LineColor);
254   FBitmap.Canvas2D.stroke;
255 
256   if MaxValue = 0 then
257     textStr := '0%'
258   else
259     textStr := FloatToStr((Value / MaxValue) * 100) + '%';
260 
261   textBmp := TextShadow(Width, Height, textStr, Font.Height,
262     Font.Color, FontShadowColor, FontShadowOFfsetX,
263     FontShadowOffsetY, FontSHadowRadius, Font.Style, Font.Name) as TBGRABitmap;
264   FBitmap.PutImage(0, 0, textBmp, dmDrawWithTransparency);
265   textBmp.Free;
266 end;
267 
268 procedure TBCRadialProgressBar.SetColor(Value: TColor);
269 begin
270   inherited SetColor(Value);
271   RenderControl;
272   Invalidate;
273 end;
274 
275 constructor TBCRadialProgressBar.Create(AOwner: TComponent);
276 begin
277   inherited Create(AOwner);
278 
279   with GetControlClassDefaultSize do
280     SetInitialBounds(0, 0, 200, 200);
281   FMaxValue := 100;
282   FMinValue := 0;
283   FValue := 0;
284   FLineColor := clBlack;
285   FLineBkgColor := clSilver;
286   FLineWidth:=0;
287   FFontShadowColor := clBlack;
288   FFontShadowOffsetX := 2;
289   FFontShadowOffsetY := 2;
290   FFontShadowRadius := 4;
291   Font.Color := clBlack;
292   Font.Height := 20;
293   Color := clWhite;
294 end;
295 
296 destructor TBCRadialProgressBar.Destroy;
297 begin
298   FreeAndNil(FBitmap);
299   inherited Destroy;
300 end;
301 
302 end.
303