1 // SPDX-License-Identifier: LGPL-3.0-only (modified to allow linking)
2 {
3 Created by BGRA Controls Team
4 Dibo, Circular, lainz (007) and contributors.
5 For detailed information see readme.txt
6
7 Site: https://sourceforge.net/p/bgra-controls/
8 Wiki: http://wiki.lazarus.freepascal.org/BGRAControls
9 Forum: http://forum.lazarus.freepascal.org/index.php/board,46.0.html
10 }
11 {******************************* CONTRIBUTOR(S) ******************************
12 - Edivando S. Santos Brasil | mailedivando@gmail.com
13 (Compatibility with delphi VCL 11/2018)
14
15 ***************************** END CONTRIBUTOR(S) *****************************}
16 unit BGRAGraphicControl;
17
18 {$I bgracontrols.inc}
19
20 interface
21
22 uses
23 Classes, SysUtils, {$IFDEF FPC}LResources,{$ENDIF} Forms, Controls, Graphics, Dialogs, Types,
24 {$IFNDEF FPC}BGRAGraphics, GraphType, FPImage, {$ENDIF}
25 BCBaseCtrls, ExtCtrls, BGRABitmap, BCTypes;
26
27 type
28
29 { TCustomBGRAGraphicControl }
30
31 TCustomBGRAGraphicControl = class(TBGRAGraphicCtrl)
32 private
33 { Private declarations }
34 FOnRedraw: TBGRARedrawEvent;
35 FBevelInner, FBevelOuter: TPanelBevel;
36 FBevelWidth: TBevelWidth;
37 FBorderWidth: TBorderWidth;
38 FAlignment: TAlignment;
39 FColorOpacity: byte;
GetBitmapHeightnull40 function GetBitmapHeight: integer;
GetBitmapScalenull41 function GetBitmapScale: double;
GetBitmapWidthnull42 function GetBitmapWidth: integer;
43 procedure SetAlignment(const Value: TAlignment);
44 procedure SetBevelInner(const AValue: TPanelBevel);
45 procedure SetBevelOuter(const AValue: TPanelBevel);
46 procedure SetBevelWidth(const AValue: TBevelWidth);
47 procedure SetBitmapAutoScale(AValue: boolean);
48 procedure SetBorderWidth(const AValue: TBorderWidth);
49 procedure SetColorOpacity(const AValue: byte);
50 protected
51 { Protected declarations }
52 FBGRA: TBGRABitmap;
53 FBitmapAutoScale: boolean;
54 procedure Paint; override;
55 procedure Resize; override;
56 procedure BGRASetSize(AWidth, AHeight: integer); virtual;
57 procedure RedrawBitmapContent; virtual;
58 procedure SetColor(Value: TColor); override;
59 procedure SetEnabled(Value: boolean); override;
60 procedure TextChanged; override;
61 property BitmapAutoScale: boolean read FBitmapAutoScale write SetBitmapAutoScale default true;
62 property BitmapScale: double read GetBitmapScale;
63 property BitmapWidth: integer read GetBitmapWidth;
64 property BitmapHeight: integer read GetBitmapHeight;
65 public
66 { Public declarations }
67 constructor Create(TheOwner: TComponent); override;
68 procedure RedrawBitmap;
69 procedure DiscardBitmap;
70 destructor Destroy; override;
71 property OnRedraw: TBGRARedrawEvent Read FOnRedraw Write FOnRedraw;
72 property Bitmap: TBGRABitmap Read FBGRA;
73 property BorderWidth: TBorderWidth Read FBorderWidth Write SetBorderWidth default 0;
74 property BevelInner: TPanelBevel Read FBevelInner Write SetBevelInner default bvNone;
75 property BevelOuter: TPanelBevel
76 Read FBevelOuter Write SetBevelOuter default bvRaised;
77 property BevelWidth: TBevelWidth Read FBevelWidth Write SetBevelWidth default 1;
78 property ColorOpacity: byte Read FColorOpacity Write SetColorOpacity;
79 property Alignment: TAlignment Read FAlignment Write SetAlignment;
80 end;
81
82 TBGRAGraphicControl = class(TCustomBGRAGraphicControl)
83 published
84 { Published declarations }
85 property Align;
86 property Anchors;
87 property OnRedraw;
88 property Bitmap;
89 property BitmapAutoscale;
90 property BitmapScale;
91 property BorderWidth;
92 property BevelInner;
93 property BevelOuter;
94 property BevelWidth;
95 property Color;
96 property ColorOpacity;
97 property Alignment;
98 property OnClick;
99 property OnDblClick;
100 property OnMouseDown;
101 property OnMouseEnter;
102 property OnMouseLeave;
103 property OnMouseMove;
104 property OnMouseUp;
105 {$IFDEF FPC}
106 property OnPaint;
107 {$ENDIF}
108 property Caption;
109 end;
110
111 {$IFDEF FPC}procedure Register;{$ENDIF}
112
113 implementation
114
115 uses BGRABitmapTypes, LazVersion;
116
117 {$IFDEF FPC}
118 procedure Register;
119 begin
120 //{$I icons\bgragraphiccontrol_icon.lrs}
121 RegisterComponents('BGRA Controls', [TBGRAGraphicControl]);
122 end;
123 {$ENDIF}
124
125 procedure TCustomBGRAGraphicControl.SetAlignment(const Value: TAlignment);
126 begin
127 if FAlignment = Value then
128 exit;
129 FAlignment := Value;
130 DiscardBitmap;
131 end;
132
TCustomBGRAGraphicControl.GetBitmapHeightnull133 function TCustomBGRAGraphicControl.GetBitmapHeight: integer;
134 begin
135 result := round(ClientHeight * BitmapScale);
136 end;
137
GetBitmapScalenull138 function TCustomBGRAGraphicControl.GetBitmapScale: double;
139 begin
140 {$if laz_fullversion >= 2000000}
141 if not FBitmapAutoScale then
142 result := GetCanvasScaleFactor
143 else
144 result := 1;
145 {$else}
146 result := 1;
147 {$endif}
148 end;
149
GetBitmapWidthnull150 function TCustomBGRAGraphicControl.GetBitmapWidth: integer;
151 begin
152 result := round(ClientWidth * BitmapScale);
153 end;
154
155 procedure TCustomBGRAGraphicControl.SetBevelInner(const AValue: TPanelBevel);
156 begin
157 if FBevelInner = AValue then
158 exit;
159 FBevelInner := AValue;
160 DiscardBitmap;
161 end;
162
163 procedure TCustomBGRAGraphicControl.SetBevelOuter(const AValue: TPanelBevel);
164 begin
165 if FBevelOuter = AValue then
166 exit;
167 FBevelOuter := AValue;
168 DiscardBitmap;
169 end;
170
171 procedure TCustomBGRAGraphicControl.SetBevelWidth(const AValue: TBevelWidth);
172 begin
173 if FBevelWidth = AValue then
174 exit;
175 FBevelWidth := AValue;
176 DiscardBitmap;
177 end;
178
179 procedure TCustomBGRAGraphicControl.SetBitmapAutoScale(AValue: boolean);
180 begin
181 if FBitmapAutoScale=AValue then Exit;
182 FBitmapAutoScale:=AValue;
183 DiscardBitmap;
184 end;
185
186 procedure TCustomBGRAGraphicControl.SetBorderWidth(const AValue: TBorderWidth);
187 begin
188 if FBorderWidth = AValue then
189 exit;
190 FBorderWidth := AValue;
191 DiscardBitmap;
192 end;
193
194 procedure TCustomBGRAGraphicControl.SetColorOpacity(const AValue: byte);
195 begin
196 if FColorOpacity = AValue then
197 exit;
198 FColorOpacity := AValue;
199 DiscardBitmap;
200 end;
201
202 procedure TCustomBGRAGraphicControl.Paint;
203 begin
204 BGRASetSize(BitmapWidth, BitmapHeight);
205 inherited Paint;
206 FBGRA.Draw(Canvas, rect(0, 0, ClientWidth, ClientHeight), False);
207 end;
208
209 procedure TCustomBGRAGraphicControl.Resize;
210 begin
211 inherited Resize;
212 DiscardBitmap;
213 end;
214
215 procedure TCustomBGRAGraphicControl.BGRASetSize(AWidth, AHeight: integer);
216 begin
217 if (FBGRA <> nil) and (AWidth <> FBGRA.Width) and (AHeight <> FBGRA.Height) then
218 begin
219 FBGRA.SetSize(AWidth, AHeight);
220 RedrawBitmapContent;
221 end;
222 end;
223
224 procedure TCustomBGRAGraphicControl.RedrawBitmapContent;
225 var
226 ARect: TRect;
227 TS: TTextStyle;
228 scale: Double;
229 begin
230 if (FBGRA <> nil) and (FBGRA.NbPixels <> 0) then
231 begin
232 FBGRA.Fill(ColorToBGRA(ColorToRGB(Color), FColorOpacity));
233
234 scale := BitmapScale;
235 ARect := GetClientRect;
236 ARect.Left := round(ARect.Left*scale);
237 ARect.Top := round(ARect.Top*scale);
238 ARect.Right := round(ARect.Right*scale);
239 ARect.Bottom := round(ARect.Bottom*scale);
240
241 // if BevelOuter is set then draw a frame with BevelWidth
242 if (BevelOuter <> bvNone) and (BevelWidth > 0) then
243 FBGRA.CanvasBGRA.Frame3d(ARect, round(BevelWidth*scale), BevelOuter,
244 BGRA(255, 255, 255, 200), BGRA(0, 0, 0, 160)); // Note: Frame3D inflates ARect
245
246 InflateRect(ARect, -round(BorderWidth*scale), -round(BorderWidth*scale));
247
248 // if BevelInner is set then skip the BorderWidth and draw a frame with BevelWidth
249 if (BevelInner <> bvNone) and (BevelWidth > 0) then
250 FBGRA.CanvasBGRA.Frame3d(ARect, round(BevelWidth*scale), BevelInner,
251 BGRA(255, 255, 255, 160), BGRA(0, 0, 0, 160)); // Note: Frame3D inflates ARect
252
253 if Caption <> '' then
254 begin
255 FBGRA.CanvasBGRA.Font.Assign(Canvas.Font);
256 FBGRA.CanvasBGRA.Font.Height:= round(FBGRA.CanvasBGRA.Font.Height*scale);
257 {$IFDEF FPC}//#
258 TS := Canvas.TextStyle;
259 {$ENDIF}
260 TS.Alignment := Alignment;
261 TS.Layout := tlCenter;
262 TS.Opaque := False;
263 TS.Clipping := False;
264 {$IFDEF FPC}//#
265 TS.SystemFont := Canvas.Font.IsDefault;
266 {$ENDIF}
267
268 FBGRA.CanvasBGRA.Font.Color := Color xor $FFFFFF;
269 FBGRA.CanvasBGRA.Font.Opacity := 255;
270
271 if not Enabled then
272 FBGRA.CanvasBGRA.Font.Style := [fsStrikeOut]
273 else
274 FBGRA.CanvasBGRA.Font.Style := [];
275
276 FBGRA.CanvasBGRA.TextRect(ARect, ARect.Left, ARect.Top, Caption, TS);
277 end;
278
279 if Assigned(FOnRedraw) then
280 FOnRedraw(self, FBGRA);
281 end;
282 end;
283
284 procedure TCustomBGRAGraphicControl.SetColor(Value: TColor);
285 begin
286 if Value <> Color then
287 DiscardBitmap;
288
289 inherited SetColor(Value);
290 end;
291
292 procedure TCustomBGRAGraphicControl.SetEnabled(Value: boolean);
293 begin
294 if Value <> Enabled then
295 DiscardBitmap;
296 inherited SetEnabled(Value);
297 end;
298
299 procedure TCustomBGRAGraphicControl.TextChanged;
300 begin
301 DiscardBitmap;
302 end;
303
304 constructor TCustomBGRAGraphicControl.Create(TheOwner: TComponent);
305 begin
306 inherited Create(TheOwner);
307
308 with GetControlClassDefaultSize do
309 SetInitialBounds(0, 0, CX, CY);
310
311 FBGRA := TBGRABitmap.Create;
312 FBitmapAutoScale:= true;
313 FBevelWidth := 1;
314 FAlignment := taCenter;
315 Color := clWhite;
316 FColorOpacity := 128;
317 FBevelOuter := bvRaised;
318 FBevelInner := bvNone;
319 end;
320
321 procedure TCustomBGRAGraphicControl.RedrawBitmap;
322 begin
323 RedrawBitmapContent;
324 Repaint;
325 end;
326
327 procedure TCustomBGRAGraphicControl.DiscardBitmap;
328 begin
329 if (FBGRA <> nil) and (FBGRA.NbPixels <> 0) then
330 begin
331 FBGRA.SetSize(0, 0);
332 Invalidate;
333 end;
334 end;
335
336 destructor TCustomBGRAGraphicControl.Destroy;
337 begin
338 FBGRA.Free;
339 inherited Destroy;
340 end;
341
342 end.
343