1 // SPDX-License-Identifier: LGPL-3.0-only (modified to allow linking)
2 { Equivalent of standard lazarus TPanel but using BGRA Controls framework for render
3
4 Functionality:
5 - Customizable background (gradient etc.)
6 - Customizable border (frame 3D or normal border, rounding etc)
7 - FontEx (shadow etc.)
8
9 originally written in 2011 by Krzysztof Dibowski dibowski at interia.pl
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 BCPanel;
17
18 {$I bgracontrols.inc}
19
20 interface
21
22 uses
23 Classes, SysUtils, {$IFDEF FPC}LResources,{$ENDIF} Types, Forms, Controls, Graphics, Dialogs,
24 BGRABitmap, BCBaseCtrls, BGRABitmapTypes, BCTypes, LCLVersion;
25
26 type
27 TOnAfterRenderBCPanel = procedure(Sender: TObject; const ABGRA: TBGRABitmap;
28 ARect: TRect) of object;
29 TBCPanelBorderStyle = (bpsBorder, bpsFrame3d);
30
31 { TCustomBCPanel }
32
33 TCustomBCPanel = class(TBCStyleCustomControl)
34 private
35 { Private declarations }
36 {$IFDEF INDEBUG}
37 FRenderCount: Integer;
38 {$ENDIF}
39 FBackground: TBCBackground;
40 FBevelWidth: Integer;
41 FBGRA: TBGRABitmapEx;
42 FBevelInner, FBevelOuter : TBevelCut;
43 FBorder: TBCBorder;
44 FBorderBCStyle: TBCPanelBorderStyle;
45 FFontEx: TBCFont;
46 FOnAfterRenderBCPanel: TOnAfterRenderBCPanel;
47 FRounding: TBCRounding;
48 procedure SetBackground(AValue: TBCBackground);
49 procedure SetBevelInner(AValue: TBevelCut);
50 procedure SetBevelOuter(AValue: TBevelCut);
51 procedure SetBevelWidth(AValue: Integer);
52 procedure SetBorder(AValue: TBCBorder);
53 procedure SetBorderBCStyle(AValue: TBCPanelBorderStyle);
54 procedure SetFontEx(AValue: TBCFont);
55 procedure SetRounding(AValue: TBCRounding);
56 procedure Render;
57 procedure OnChangeProperty({%H-}Sender: TObject; {%H-}AData: BGRAPtrInt);
58 procedure OnChangeFont({%H-}Sender: TObject; {%H-}AData: BGRAPtrInt);
59 protected
60 { Protected declarations }
61 procedure AdjustClientRect(var aRect: TRect); override;
GetControlClassDefaultSizenull62 class function GetControlClassDefaultSize: TSize; override;
GetDefaultDockCaptionnull63 function GetDefaultDockCaption: String; override;
64 procedure SetEnabled(Value: boolean); override;
65 procedure TextChanged; override;
66 protected
GetStyleExtensionnull67 function GetStyleExtension: String; override;
68 {$IFDEF INDEBUG}
GetDebugTextnull69 function GetDebugText: String; override;
70 {$ENDIF}
71 procedure DrawControl; override;
72 procedure RenderControl; override;
73 protected
74 {$IF LCL_FULLVERSION >= 2080000}
75 procedure SetParentBackground(const AParentBackground: Boolean); override;
76 {$ENDIF}
77 property Background: TBCBackground read FBackground write SetBackground;
78 property BevelInner: TBevelCut read FBevelInner write SetBevelInner;
79 property BevelOuter: TBevelCut read FBevelOuter write SetBevelOuter;
80 property BevelWidth: Integer read FBevelWidth write SetBevelWidth;
81 property Border: TBCBorder read FBorder write SetBorder;
82 property BorderBCStyle: TBCPanelBorderStyle
83 read FBorderBCStyle write SetBorderBCStyle default bpsFrame3d;
84 property FontEx: TBCFont read FFontEx write SetFontEx;
85 property Rounding: TBCRounding read FRounding write SetRounding;
86 protected
87 { Events }
88 property OnAfterRenderBCPanel: TOnAfterRenderBCPanel
89 Read FOnAfterRenderBCPanel Write FOnAfterRenderBCPanel;
90 public
91 { Public declarations }
92 constructor Create(TheOwner: TComponent); override;
93 destructor Destroy; override;
94 procedure UpdateControl; override; // Called by EndUpdate
95 public
96 { Streaming }
97 {$IFDEF FPC}
98 procedure SaveToFile(AFileName: string);
99 procedure LoadFromFile(AFileName: string);
100 {$ENDIF}
101 procedure OnFindClass({%H-}Reader: TReader; const AClassName: string;
102 var ComponentClass: TComponentClass);
103 end;
104
105 { TBCPanel }
106
107 TBCPanel = class(TCustomBCPanel)
108 published
109 property Align;
110 property Anchors;
111 property AssignStyle;
112 property AutoSize;
113 property BorderSpacing;
114 property ChildSizing;
115 {$IFDEF FPC} //#
116 property OnGetDockCaption;
117 {$ENDIF}
118 property Background;
119 property BevelInner;
120 property BevelOuter;
121 property BevelWidth;
122 property Border;
123 property BorderBCStyle;
124 property Caption;
125 property Constraints;
126 property DockSite;
127 property DragCursor;
128 property DragKind;
129 property DragMode;
130 property Enabled;
131 property FontEx;
132 property ParentBackground;
133 property PopupMenu;
134 property Rounding;
135 property ShowHint;
136 property TabOrder;
137 property TabStop;
138 property UseDockManager default True;
139 property Visible;
140 property OnClick;
141 property OnContextPopup;
142 property OnDockDrop;
143 property OnDockOver;
144 property OnDblClick;
145 property OnDragDrop;
146 property OnDragOver;
147 property OnEndDock;
148 property OnEndDrag;
149 property OnEnter;
150 property OnExit;
151 property OnGetSiteInfo;
152 property OnMouseDown;
153 property OnMouseEnter;
154 property OnMouseLeave;
155 property OnMouseMove;
156 property OnMouseUp;
157 property OnMouseWheel;
158 property OnMouseWheelDown;
159 property OnMouseWheelUp;
160 property OnResize;
161 property OnStartDock;
162 property OnStartDrag;
163 property OnUnDock;
164 property OnAfterRenderBCPanel;
165 end;
166
167 {$IFDEF FPC}procedure Register;{$ENDIF}
168
169 implementation
170
171 uses BCTools;
172
173 {$IFDEF FPC}
174 procedure Register;
175 begin
176 //{$I icons\bcpanel_icon.lrs}
177 RegisterComponents('BGRA Controls', [TBCPanel]);
178 end;
179 {$ENDIF}
180
181 { TCustomBCPanel }
182
183 procedure TCustomBCPanel.DrawControl;
184 begin
185 inherited DrawControl;
186 if FBGRA.NeedRender then
187 Render;
188 if Assigned (FRounding) then
189 begin
190 if (FRounding.RoundX<>0) and (FRounding.RoundY<>0) then
191 FBGRA.Draw(Self.Canvas, 0, 0, False)
192 else
193 FBGRA.Draw(Self.Canvas, 0, 0);
194 end
195 else
196 FBGRA.Draw(Self.Canvas, 0, 0);
197
198 {$IFNDEF FPC}//# //@ IN DELPHI RenderControl NEDD. IF NO RenderControl BE BLACK AFTER INVALIDATE.
199 FBGRA.NeedRender := True;
200 {$ENDIF}
201 end;
202
203 procedure TCustomBCPanel.RenderControl;
204 begin
205 inherited RenderControl;
206 if FBGRA<>nil then
207 FBGRA.NeedRender := True;
208 end;
209
210 {$IF LCL_FULLVERSION >= 2080000}
211 procedure TCustomBCPanel.SetParentBackground(const AParentBackground: Boolean);
212 begin
213 if ParentBackground=AParentBackground then
214 Exit;
215 if AParentBackground then
216 ControlStyle := ControlStyle - [csOpaque]
217 else
218 ControlStyle := ControlStyle + [csOpaque];
219 inherited;
220 end;
221 {$ENDIF}
222
TCustomBCPanel.GetStyleExtensionnull223 function TCustomBCPanel.GetStyleExtension: String;
224 begin
225 Result := 'bcpnl';
226 end;
227
228 {$IFDEF INDEBUG}
TCustomBCPanel.GetDebugTextnull229 function TCustomBCPanel.GetDebugText: String;
230 begin
231 Result := 'R: '+IntToStr(FRenderCount);
232 end;
233 {$ENDIF}
234
235 procedure TCustomBCPanel.Render;
236 var r: TRect;
237 begin
238 if (csCreating in ControlState) or IsUpdating then
239 Exit;
240
241 FBGRA.NeedRender := False;
242
243 FBGRA.SetSize(Width, Height);
244 FBGRA.Fill(BGRAPixelTransparent);
245 r := FBGRA.ClipRect;
246
247 case FBorderBCStyle of
248 bpsBorder:
249 begin
250 RenderBackgroundAndBorder(FBGRA.ClipRect, FBackground, TBGRABitmap(FBGRA), FRounding, FBorder);
251 CalculateBorderRect(FBorder,r);
252 end;
253 bpsFrame3d:
254 begin
255 // if BevelOuter is set then draw a frame with BevelWidth
256 if (FBevelOuter <> bvNone) and (FBevelWidth > 0) then
257 FBGRA.CanvasBGRA.Frame3d(r, FBevelWidth, FBevelOuter,
258 BGRA(255, 255, 255, 180), BGRA(0, 0, 0, 160)); // Note: Frame3D inflates ARect
259
260 // if BevelInner is set then skip the BorderWidth and draw a frame with BevelWidth
261 if (FBevelInner <> bvNone) and (FBevelWidth > 0) then
262 begin
263 InflateRect(r, -FBevelWidth, -FBevelWidth);
264 FBGRA.CanvasBGRA.Frame3d(r, FBevelWidth, FBevelInner,
265 BGRA(255, 255, 255, 160), BGRA(0, 0, 0, 160)); // Note: Frame3D inflates ARect
266 end;
267 RenderBackground(r, FBackground, TBGRABitmap(FBGRA), nil, True);
268 end;
269 else
270 RenderBackground(FBGRA.ClipRect, FBackground, TBGRABitmap(FBGRA), FRounding, True);
271 end;
272
273 if Caption <> '' then
274 RenderText(r,FFontEx,Caption,TBGRABitmap(FBGRA));
275
276 if Assigned(FOnAfterRenderBCPanel) then
277 FOnAfterRenderBCPanel(Self, FBGRA, r);
278
279 {$IFDEF INDEBUG}
280 FRenderCount := FRenderCount + 1;
281 {$ENDIF}
282 end;
283
284 procedure TCustomBCPanel.OnChangeProperty(Sender: TObject; AData: BGRAPtrInt);
285 begin
286 RenderControl;
287 Invalidate;
288 end;
289
290 procedure TCustomBCPanel.OnChangeFont(Sender: TObject; AData: BGRAPtrInt);
291 begin
292 RenderControl;
293 Invalidate;
294 end;
295
296 procedure TCustomBCPanel.SetRounding(AValue: TBCRounding);
297 begin
298 if FRounding = AValue then Exit;
299 FRounding.Assign(AValue);
300
301 RenderControl;
302 Invalidate;
303 end;
304
305 procedure TCustomBCPanel.AdjustClientRect(var aRect: TRect);
306 var BevelSize: Integer;
307 begin
308 inherited AdjustClientRect(aRect);
309
310 BevelSize := BorderWidth;
311 if (BevelOuter <> bvNone) then
312 inc(BevelSize, BevelWidth);
313 if (BevelInner <> bvNone) then
314 inc(BevelSize, BevelWidth);
315
316 InflateRect(aRect, -BevelSize, -BevelSize);
317 end;
318
TCustomBCPanel.GetControlClassDefaultSizenull319 class function TCustomBCPanel.GetControlClassDefaultSize: TSize;
320 begin
321 Result.CX := 170;
322 Result.CY := 50;
323 end;
324
TCustomBCPanel.GetDefaultDockCaptionnull325 function TCustomBCPanel.GetDefaultDockCaption: String;
326 begin
327 Result := Caption;
328 end;
329
330 procedure TCustomBCPanel.SetBackground(AValue: TBCBackground);
331 begin
332 if FBackground = AValue then Exit;
333 FBackground.Assign(AValue);
334
335 RenderControl;
336 Invalidate;
337 end;
338
339 procedure TCustomBCPanel.SetBevelInner(AValue: TBevelCut);
340 begin
341 if FBevelInner = AValue then Exit;
342 FBevelInner := AValue;
343
344 RenderControl;
345 Invalidate;
346 end;
347
348 procedure TCustomBCPanel.SetBevelOuter(AValue: TBevelCut);
349 begin
350 if FBevelOuter = AValue then Exit;
351 FBevelOuter := AValue;
352
353 RenderControl;
354 Invalidate;
355 end;
356
357 procedure TCustomBCPanel.SetBevelWidth(AValue: Integer);
358 begin
359 if FBevelWidth = AValue then Exit;
360 FBevelWidth := AValue;
361
362 RenderControl;
363 Invalidate;
364 end;
365
366 procedure TCustomBCPanel.SetBorder(AValue: TBCBorder);
367 begin
368 if FBorder = AValue then Exit;
369 FBorder.Assign(AValue);
370
371 RenderControl;
372 Invalidate;
373 end;
374
375 procedure TCustomBCPanel.SetBorderBCStyle(AValue: TBCPanelBorderStyle);
376 begin
377 if FBorderBCStyle = AValue then Exit;
378 FBorderBCStyle := AValue;
379
380 RenderControl;
381 Invalidate;
382 end;
383
384 procedure TCustomBCPanel.SetFontEx(AValue: TBCFont);
385 begin
386 if FFontEx = AValue then Exit;
387 FFontEx.Assign(AValue);
388
389 RenderControl;
390 Invalidate;
391 end;
392
393 procedure TCustomBCPanel.SetEnabled(Value: boolean);
394 begin
395 inherited SetEnabled(Value);
396
397 RenderControl;
398 Invalidate;
399 end;
400
401 procedure TCustomBCPanel.TextChanged;
402 begin
403 {$IFDEF FPC}
404 inherited TextChanged;
405 {$ENDIF}
406
407 RenderControl;
408 Invalidate;
409 end;
410
411 constructor TCustomBCPanel.Create(TheOwner: TComponent);
412 begin
413 inherited Create(TheOwner);
414 {$IFDEF INDEBUG}
415 FRenderCount := 0;
416 {$ENDIF}
417 {$IFDEF FPC}
418 DisableAutoSizing;
419 Include(FControlState, csCreating);
420 {$ELSE} //#
421
422 {$ENDIF}
423
424 BeginUpdate;
425 try
426 ControlStyle := ControlStyle + [csAcceptsControls, csCaptureMouse,
427 csClickEvents, csSetCaption, csDoubleClicks, csReplicatable{$IFDEF FPC},
428 csNoFocus, csAutoSize0x0{$ENDIF}]
429 + [csOpaque]; // we need the default background
430 //Self.DoubleBuffered := True;
431 with GetControlClassDefaultSize do
432 SetInitialBounds(0, 0, CX, CY);
433
434 FBGRA := TBGRABitmapEx.Create;
435 FBorderBCStyle := bpsFrame3d;
436 FBackground := TBCBackground.Create(Self);
437 FBorder := TBCBorder.Create(Self);
438 FFontEx := TBCFont.Create(Self);
439 FBevelOuter := bvRaised;
440 FBevelInner := bvNone;
441 FBevelWidth := 1;
442 ParentColor := True;
443 UseDockManager := True;
444
445 FBackground.OnChange := OnChangeProperty;
446 FBorder.OnChange := OnChangeProperty;
447 FFontEx.OnChange := OnChangeFont;
448
449 FBackground.Style := bbsColor;
450 FBackground.Color := {$ifdef UseCLDefault}clDefault{$else}clBtnFace{$endif};
451 FBorder.Style := bboNone;
452
453 FRounding := TBCRounding.Create(Self);
454 FRounding.OnChange := OnChangeProperty;
455 finally
456 {$IFDEF FPC}
457 EnableAutoSizing;
458 {$ENDIF}
459 EndUpdate;
460 {$IFDEF FPC}
461 Exclude(FControlState, csCreating);
462 {$ELSE} //#
463 {$ENDIF}
464 end;
465 end;
466
467 destructor TCustomBCPanel.Destroy;
468 begin
469 FBackground.Free;
470 FBorder.Free;
471 FFontEx.Free;
472 FBGRA.Free;
473 FRounding.Free;
474 inherited Destroy;
475 end;
476
477 procedure TCustomBCPanel.UpdateControl;
478 begin
479 Render;
480 inherited UpdateControl; // invalidate
481 end;
482 {$IFDEF FPC}
483 procedure TCustomBCPanel.SaveToFile(AFileName: string);
484 var
485 AStream: TMemoryStream;
486 begin
487 AStream := TMemoryStream.Create;
488 try
489 WriteComponentAsTextToStream(AStream, Self);
490 AStream.SaveToFile(AFileName);
491 finally
492 AStream.Free;
493 end;
494 end;
495
496 procedure TCustomBCPanel.LoadFromFile(AFileName: string);
497 var
498 AStream: TMemoryStream;
499 begin
500 AStream := TMemoryStream.Create;
501 try
502 AStream.LoadFromFile(AFileName);
503 ReadComponentFromTextStream(AStream, TComponent(Self), OnFindClass);
504 finally
505 AStream.Free;
506 end;
507 end;
508 {$ENDIF}
509
510 procedure TCustomBCPanel.OnFindClass(Reader: TReader; const AClassName: string;
511 var ComponentClass: TComponentClass);
512 begin
513 if CompareText(AClassName, 'TBCPanel') = 0 then
514 ComponentClass := TBCPanel;
515 end;
516
517 end.
518