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