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