1 // SPDX-License-Identifier: LGPL-3.0-only (modified to allow linking)
2 {
3   BCRoundedImage
4   by Lainz
5 
6   Last modified: 2020-09-06 19:16 GMT-3
7 
8   Changelog:
9   - 2020-09-06: Initial version supporting circle, rounded rectangle and square.
10                 Changing the quality of the resample, setting the rounding.
11                 OnPaintEvent to customize the final drawing.
12 }
13 unit BCRoundedImage;
14 
15 {$mode objfpc}{$H+}
16 
17 interface
18 
19 uses
20   Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
21   BGRABitmap, BGRABitmapTypes;
22 
23 type
24   TBCRoundedImage = class;
25 
26   // Event to draw before the image is sent to canvas
27   TBCRoundedImagePaintEvent = procedure (const Sender: TBCRoundedImage; const Bitmap: TBGRABitmap) of object;
28   // Supported styles are circle, rounded rectangle and square
29   TBCRoundedImageStyle = (isCircle, isRoundedRectangle, isSquare);
30 
31   // Control that draws an image within a rounded border
32 
33   { TBCRoundedImage }
34 
35   TBCRoundedImage = class(TGraphicControl)
36   private
37     FBorderStyle: TRoundRectangleOptions;
38     FOnPaintEvent: TBCRoundedImagePaintEvent;
39     FPicture: TPicture;
40     FQuality: TResampleFilter;
41     FStyle: TBCRoundedImageStyle;
42     FRounding: single;
43     procedure SetBorderStyle(AValue: TRoundRectangleOptions);
44     procedure SetPicture(AValue: TPicture);
45     procedure SetQuality(AValue: TResampleFilter);
46     procedure SetStyle(AValue: TBCRoundedImageStyle);
47     procedure SetRounding(AValue: single);
48   protected
49   public
50     constructor Create(AOwner: TComponent); override;
51     destructor Destroy; override;
52     procedure Paint; override;
53   published
54     // The image that's used as background
55     property Picture: TPicture read FPicture write SetPicture;
56     // The style can be circle, rounded rectangle or square
57     property Style: TBCRoundedImageStyle read FStyle write SetStyle;
58     // The style of the rounded rectangle
59     property BorderStyle: TRoundRectangleOptions read FBorderStyle write SetBorderStyle;
60     // Rounding is used when you choose the rounded rectangle style
61     property Rounding: single read FRounding write SetRounding;
62     // The quality when resizing the image
63     property Quality: TResampleFilter read FQuality write SetQuality;
64     // You can paint before the bitmap is drawn on canvas
65     property OnPaintEvent: TBCRoundedImagePaintEvent read FOnPaintEvent write FOnPaintEvent;
66   published
67     property Anchors;
68     property Align;
69     property OnMouseEnter;
70     property OnMouseLeave;
71     property OnClick;
72   end;
73 
74 procedure Register;
75 
76 implementation
77 
78 procedure Register;
79 begin
80   RegisterComponents('BGRA Controls', [TBCRoundedImage]);
81 end;
82 
83 procedure TBCRoundedImage.SetPicture(AValue: TPicture);
84 begin
85   if FPicture = AValue then
86     Exit;
87   FPicture := AValue;
88   Invalidate;
89 end;
90 
91 procedure TBCRoundedImage.SetBorderStyle(AValue: TRoundRectangleOptions);
92 begin
93   if FBorderStyle=AValue then Exit;
94   FBorderStyle:=AValue;
95   Invalidate;
96 end;
97 
98 procedure TBCRoundedImage.SetQuality(AValue: TResampleFilter);
99 begin
100   if FQuality = AValue then
101     Exit;
102   FQuality := AValue;
103   Invalidate;
104 end;
105 
106 procedure TBCRoundedImage.SetStyle(AValue: TBCRoundedImageStyle);
107 begin
108   if FStyle = AValue then
109     Exit;
110   FStyle := AValue;
111   Invalidate;
112 end;
113 
114 procedure TBCRoundedImage.SetRounding(AValue: single);
115 begin
116   if FRounding = AValue then
117     Exit;
118   FRounding := AValue;
119   Invalidate;
120 end;
121 
122 constructor TBCRoundedImage.Create(AOwner: TComponent);
123 begin
124   inherited Create(AOwner);
125   FPicture := TPicture.Create;
126   FRounding := 10;
127   FQuality := rfBestQuality;
128 end;
129 
130 destructor TBCRoundedImage.Destroy;
131 begin
132   FPicture.Free;
133   inherited Destroy;
134 end;
135 
136 procedure TBCRoundedImage.Paint;
137 var
138   bgra: TBGRABitmap;
139   image: TBGRABitmap;
140 begin
141   if (FPicture.Width = 0) or (FPicture.Height = 0) then
142     Exit;
143   // Picture
144   image := TBGRABitmap.Create(FPicture.Bitmap);
145   bgra := TBGRABitmap.Create(Width, Height, BGRAPixelTransparent);
146   try
147     // Quality
148     image.ResampleFilter := FQuality;
149     BGRAReplace(image, image.Resample(Width, Height));
150     // Style
151     case FStyle of
152       isCircle: bgra.FillEllipseAntialias(Width div 2, Height div 2,
153           Width div 2, Height div 2, image);
154       // Rounding, BorderStyle
155       isRoundedRectangle: bgra.FillRoundRectAntialias(0, 0, Width,
156           Height, FRounding, FRounding, image, FBorderStyle);
157       else
158         bgra.PutImage(0, 0, image, dmDrawWithTransparency);
159     end;
160     // OnPaintEvent
161     if Assigned(FOnPaintEvent) then
162       FOnPaintEvent(Self, bgra);
163     bgra.Draw(Canvas, 0, 0, False);
164   finally
165     bgra.Free;
166     image.Free;
167   end;
168 end;
169 
170 end.
171