1 // SPDX-License-Identifier: LGPL-3.0-only (modified to allow linking)
2 unit BCGradientButton;
3 
4 {$mode delphi}
5 
6 interface
7 
8 uses
9   Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
10   BGRABitmap, BGRABitmapTypes, BCTypes;
11 
12 type
13 
14   { TBCGradientButton }
15 
16   TBCGradientButton = class(TGraphicControl)
17   private
18     FBorderColor: TBCPixel;
19     FBorderSize: integer;
20     FColor1: TBCPixel;
21     FColor2: TBCPixel;
22     FDimColor: TBCPixel;
23     FLockHorizontal: boolean;
24     FLockVertical: boolean;
25     FOnAfterRedraw: TBGRARedrawEvent;
26     FOnBeforeRedraw: TBGRARedrawEvent;
27     Fx: integer;
28     Fy: integer;
29     Fdraw: boolean;
30     Fupdating: boolean;
31     Fdown: boolean;
32     procedure ColorInvalidate({%H-}ASender: TObject; {%H-}AData: PtrInt);
33     procedure SetBorderColor(AValue: TBCPixel);
34     procedure SetBorderSize(AValue: integer);
35     procedure SetColor1(AValue: TBCPixel);
36     procedure SetColor2(AValue: TBCPixel);
37     procedure SetDimColor(AValue: TBCPixel);
38     procedure SetLockHorizontal(AValue: boolean);
39     procedure SetLockVertical(AValue: boolean);
40   protected
41     procedure Paint; override;
42     procedure MouseMove(Shift: TShiftState; X, Y: integer); override;
43     procedure MouseLeave; override;
44     procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
45     procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: integer); override;
46   public
47     constructor Create(AOwner: TComponent); override;
48     destructor Destroy; override;
49     procedure Invalidate; override;
50     procedure BeginUpdate;
51     procedure EndUpdate;
52   published
53     property LockHorizontal: boolean read FLockHorizontal
54       write SetLockHorizontal default False;
55     property LockVertical: boolean
56       read FLockVertical write SetLockVertical default False;
57     property DimColor: TBCPixel read FDimColor write SetDimColor;
58     property Color1: TBCPixel read FColor1 write SetColor1;
59     property Color2: TBCPixel read FColor2 write SetColor2;
60     property BorderColor: TBCPixel read FBorderColor write SetBorderColor;
61     property BorderSize: integer read FBorderSize write SetBorderSize;
62     property OnBeforeRedraw: TBGRARedrawEvent read FOnBeforeRedraw write FOnBeforeRedraw;
63     property OnAfterRedraw: TBGRARedrawEvent read FOnAfterRedraw write FOnAfterRedraw;
64   published
65     property Align;
66     property Anchors;
67     property BorderSpacing;
68     property Caption;
69     property Enabled;
70     property ShowHint;
71   end;
72 
73 procedure Register;
74 
75 implementation
76 
77 procedure Register;
78 begin
79   RegisterComponents('BGRA Button Controls', [TBCGradientButton]);
80 end;
81 
82 { TBCGradientButton }
83 
84 procedure TBCGradientButton.SetLockHorizontal(AValue: boolean);
85 begin
86   if FLockHorizontal = AValue then
87     Exit;
88   FLockHorizontal := AValue;
89   Invalidate;
90 end;
91 
92 procedure TBCGradientButton.SetColor1(AValue: TBCPixel);
93 begin
94   if FColor1 = AValue then
95     Exit;
96   FColor1 := AValue;
97   Invalidate;
98 end;
99 
100 procedure TBCGradientButton.SetBorderColor(AValue: TBCPixel);
101 begin
102   if FBorderColor = AValue then
103     Exit;
104   FBorderColor := AValue;
105   Invalidate;
106 end;
107 
108 procedure TBCGradientButton.ColorInvalidate(ASender: TObject; AData: PtrInt);
109 begin
110   Invalidate;
111 end;
112 
113 procedure TBCGradientButton.SetBorderSize(AValue: integer);
114 begin
115   if FBorderSize = AValue then
116     Exit;
117   FBorderSize := AValue;
118   Invalidate;
119 end;
120 
121 procedure TBCGradientButton.SetColor2(AValue: TBCPixel);
122 begin
123   if FColor2 = AValue then
124     Exit;
125   FColor2 := AValue;
126   Invalidate;
127 end;
128 
129 procedure TBCGradientButton.SetDimColor(AValue: TBCPixel);
130 begin
131   if FDimColor = AValue then
132     Exit;
133   FDimColor := AValue;
134   Invalidate;
135 end;
136 
137 procedure TBCGradientButton.SetLockVertical(AValue: boolean);
138 begin
139   if FLockVertical = AValue then
140     Exit;
141   FLockVertical := AValue;
142   Invalidate;
143 end;
144 
145 procedure TBCGradientButton.Paint;
146 var
147   bmp: TBGRABitmap;
148   x, y: integer;
149 begin
150   bmp := TBGRABitmap.Create(Width, Height);
151   if Assigned(FOnBeforeRedraw) then
152     FOnBeforeRedraw(Self, bmp);
153   if Fdraw and Enabled then
154   begin
155     x := Fx;
156     y := Fy;
157     if FLockHorizontal then
158       x := Width div 2;
159     if FLockVertical then
160       y := Height div 2;
161     bmp.GradientFill(0, 0, Width, Height, FColor1.Pixel, FColor2.Pixel, gtRadial,
162       PointF(x, y), PointF(x - Width, y), dmDrawWithTransparency);
163     bmp.RectangleAntialias(0, 0, Width, Height, FBorderColor.Pixel,
164       FBorderSize, BGRAPixelTransparent);
165     if Fdown then
166       bmp.Rectangle(0, 0, Width, Height, FDimColor.Pixel, FDimColor.Pixel,
167         dmDrawWithTransparency);
168   end;
169   if Assigned(FOnAfterRedraw) then
170     FOnAfterRedraw(Self, bmp);
171   bmp.Draw(Canvas, 0, 0, False);
172   bmp.Free;
173 end;
174 
175 procedure TBCGradientButton.Invalidate;
176 begin
177   if Fupdating then
178     Exit;
179   inherited Invalidate;
180 end;
181 
182 procedure TBCGradientButton.MouseMove(Shift: TShiftState; X, Y: integer);
183 begin
184   inherited MouseMove(Shift, X, Y);
185   Fx := X;
186   Fy := Y;
187   Fdraw := True;
188   Invalidate;
189 end;
190 
191 procedure TBCGradientButton.MouseLeave;
192 begin
193   inherited MouseLeave;
194   Fdraw := False;
195   Fdown := False;
196   Invalidate;
197 end;
198 
199 procedure TBCGradientButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
200   X, Y: integer);
201 begin
202   inherited MouseDown(Button, Shift, X, Y);
203   Fdown := True;
204   Invalidate;
205 end;
206 
207 procedure TBCGradientButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
208   X, Y: integer);
209 begin
210   inherited MouseUp(Button, Shift, X, Y);
211   Fdown := False;
212   Invalidate;
213 end;
214 
215 constructor TBCGradientButton.Create(AOwner: TComponent);
216 begin
217   inherited Create(AOwner);
218   BeginUpdate;
219   FLockHorizontal := False;
220   FLockVertical := False;
221   FColor1 := TBCPixel.Create(Self, BGRA(255, 255, 255, 100));
222   FColor1.OnChange := ColorInvalidate;
223   FColor2 := TBCPixel.Create(Self, BGRA(0, 0, 0, 0));
224   FColor2.OnChange := ColorInvalidate;
225   FBorderColor := TBCPixel.Create(Self, BGRA(255, 255, 255, 100));
226   FBorderColor.OnChange := ColorInvalidate;
227   FDimColor := TBCPixel.Create(Self, BGRA(0, 0, 0, 100));
228   FDimColor.OnChange := ColorInvalidate;
229   FBorderSize := 2;
230   Fdown := False;
231   EndUpdate;
232 end;
233 
234 destructor TBCGradientButton.Destroy;
235 begin
236   FColor1.Free;
237   FColor2.Free;
238   FBorderColor.Free;
239   FDimColor.Free;
240   inherited Destroy;
241 end;
242 
243 procedure TBCGradientButton.BeginUpdate;
244 begin
245   Fupdating := True;
246 end;
247 
248 procedure TBCGradientButton.EndUpdate;
249 begin
250   Fupdating := False;
251   Invalidate;
252 end;
253 
254 end.
255