Delphi VCL ShadowEffect like FMX TShadowEffect - delphi

Question

In Firemonkey we can use a TShadowEffect to draw a nice looking shadow.
This shadow also adjusts its opacity and translucency so it displays the correct component beneath it if a control is overlapping.
Without TShadowEffect:
With TShadowEffect:
Is there a way to draw the same shadow effect in VCL forms without embedding a FMX form?

Answer 1

My idea was to create a TGraphicControl and place it underneath the target control. The shadow control will stick to the target control. The steps of drawing the shadow are as follow:
We create an off screen Bitmap and draw a RoundRect
Then apply Gaussian Blur convolution kernel:
see http://www.concepto.ch/delphi/uddf/pages/graphics.htm#graphics9 (unit GBlur2). (EDIT: Link is dead)
Finally we make it 32 bit alpha semi transparent gray scale. depending on the amount of darkness:
And draw it via AlphaBlend on the TGraphicControl canvas.
GBlur2.pas (Author unknown)
unit GBlur2;
interface
uses
Windows, Graphics;
type
PRGBTriple = ^TRGBTriple;
TRGBTriple = packed record
b: byte; {easier to type than rgbtBlue}
g: byte;
r: byte;
end;
PRow = ^TRow;
TRow = array[0..1000000] of TRGBTriple;
PPRows = ^TPRows;
TPRows = array[0..1000000] of PRow;
const
MaxKernelSize = 100;
type
TKernelSize = 1..MaxKernelSize;
TKernel = record
Size: TKernelSize;
Weights: array[-MaxKernelSize..MaxKernelSize] of single;
end;
{the idea is that when using a TKernel you ignore the Weights except
for Weights in the range -Size..Size.}
procedure GBlur(theBitmap: TBitmap; radius: double);
implementation
uses
SysUtils;
procedure MakeGaussianKernel(var K: TKernel; radius: double; MaxData, DataGranularity: double);
{makes K into a gaussian kernel with standard deviation = radius. For the current application
you set MaxData = 255 and DataGranularity = 1. Now the procedure sets the value of K.Size so
that when we use K we will ignore the Weights that are so small they can't possibly matter. (Small
Size is good because the execution time is going to be propertional to K.Size.)}
var
j: integer;
temp, delta: double;
KernelSize: TKernelSize;
begin
for j := Low(K.Weights) to High(K.Weights) do
begin
temp := j / radius;
K.Weights[j] := exp(-temp * temp / 2);
end;
{now divide by constant so sum(Weights) = 1:}
temp := 0;
for j := Low(K.Weights) to High(K.Weights) do
temp := temp + K.Weights[j];
for j := Low(K.Weights) to High(K.Weights) do
K.Weights[j] := K.Weights[j] / temp;
{now discard (or rather mark as ignorable by setting Size) the entries that are too small to matter.
This is important, otherwise a blur with a small radius will take as long as with a large radius...}
KernelSize := MaxKernelSize;
delta := DataGranularity / (2 * MaxData);
temp := 0;
while (temp < delta) and (KernelSize > 1) do
begin
temp := temp + 2 * K.Weights[KernelSize];
dec(KernelSize);
end;
K.Size := KernelSize;
{now just to be correct go back and jiggle again so the sum of the entries we'll be using is exactly 1}
temp := 0;
for j := -K.Size to K.Size do
temp := temp + K.Weights[j];
for j := -K.Size to K.Size do
K.Weights[j] := K.Weights[j] / temp;
end;
function TrimInt(Lower, Upper, theInteger: integer): integer;
begin
if (theInteger <= Upper) and (theInteger >= Lower) then
result := theInteger
else if theInteger > Upper then
result := Upper
else
result := Lower;
end;
function TrimReal(Lower, Upper: integer; x: double): integer;
begin
if (x < upper) and (x >= lower) then
result := trunc(x)
else if x > Upper then
result := Upper
else
result := Lower;
end;
procedure BlurRow(var theRow: array of TRGBTriple; K: TKernel; P: PRow);
var
j, n: integer;
tr, tg, tb: double; {tempRed, etc}
w: double;
begin
for j := 0 to High(theRow) do
begin
tb := 0;
tg := 0;
tr := 0;
for n := -K.Size to K.Size do
begin
w := K.Weights[n];
{the TrimInt keeps us from running off the edge of the row...}
with theRow[TrimInt(0, High(theRow), j - n)] do
begin
tb := tb + w * b;
tg := tg + w * g;
tr := tr + w * r;
end;
end;
with P[j] do
begin
b := TrimReal(0, 255, tb);
g := TrimReal(0, 255, tg);
r := TrimReal(0, 255, tr);
end;
end;
Move(P[0], theRow[0], (High(theRow) + 1) * Sizeof(TRGBTriple));
end;
procedure GBlur(theBitmap: TBitmap; radius: double);
var
Row, Col: integer;
theRows: PPRows;
K: TKernel;
ACol: PRow;
P: PRow;
begin
if (theBitmap.HandleType <> bmDIB) or (theBitmap.PixelFormat <> pf24Bit) then
raise exception.Create('GBlur only works for 24-bit bitmaps');
MakeGaussianKernel(K, radius, 255, 1);
GetMem(theRows, theBitmap.Height * SizeOf(PRow));
GetMem(ACol, theBitmap.Height * SizeOf(TRGBTriple));
{record the location of the bitmap data:}
for Row := 0 to theBitmap.Height - 1 do
theRows[Row] := theBitmap.Scanline[Row];
{blur each row:}
P := AllocMem(theBitmap.Width * SizeOf(TRGBTriple));
for Row := 0 to theBitmap.Height - 1 do
BlurRow(Slice(theRows[Row]^, theBitmap.Width), K, P);
{now blur each column}
ReAllocMem(P, theBitmap.Height * SizeOf(TRGBTriple));
for Col := 0 to theBitmap.Width - 1 do
begin
{first read the column into a TRow:}
for Row := 0 to theBitmap.Height - 1 do
ACol[Row] := theRows[Row][Col];
BlurRow(Slice(ACol^, theBitmap.Height), K, P);
{now put that row, um, column back into the data:}
for Row := 0 to theBitmap.Height - 1 do
theRows[Row][Col] := ACol[Row];
end;
FreeMem(theRows);
FreeMem(ACol);
ReAllocMem(P, 0);
end;
end.
ShadowBox.pas
unit ShadowBox;
interface
uses Messages, Windows, SysUtils, Classes, Controls, Graphics, StdCtrls;
type
TShadowBox = class(TGraphicControl)
private
FControl: TControl;
FControlWndProc: TWndMethod;
procedure SetControl(AControl: TControl);
procedure ControlWndProc(var Message: TMessage);
procedure AdjustBounds;
protected
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure Paint; override;
public
destructor Destroy; override;
published
property Control: TControl read FControl write SetControl;
end;
implementation
uses GBlur2;
destructor TShadowBox.Destroy;
begin
SetControl(nil);
inherited;
end;
procedure TShadowBox.SetControl(AControl: TControl);
begin
if AControl = Self then Exit;
if FControl <> AControl then
begin
if FControl <> nil then
begin
FControl.WindowProc := FControlWndProc;
FControl.RemoveFreeNotification(Self);
end;
FControl := AControl;
if FControl <> nil then
begin
FControlWndProc := FControl.WindowProc;
FControl.WindowProc := ControlWndProc;
FControl.FreeNotification(Self);
end else
FControlWndProc := nil;
if FControl <> nil then
begin
Parent := FControl.Parent;
AdjustBounds;
end;
end;
end;
procedure TShadowBox.ControlWndProc(var Message: TMessage);
begin
if Assigned(FControlWndProc) then
FControlWndProc(Message);
case Message.Msg of
CM_VISIBLECHANGED:
Visible := FControl.Visible;
WM_WINDOWPOSCHANGED:
begin
if Parent <> FControl.Parent then
Parent := FControl.Parent;
AdjustBounds;
end;
end;
end;
procedure TShadowBox.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited;
if (Operation = opRemove) and (AComponent = FControl) then
begin
FControl := nil;
FControlWndProc := nil;
end;
end;
procedure TShadowBox.AdjustBounds;
begin
if FControl <> nil then
begin
SetBounds(FControl.Left - 8, FControl.Top - 8, FControl.Width + 16, FControl.Height + 16);
if FControl is TWinControl then
BringToFront
else
SendToBack;
end;
end;
procedure PrepareBitmap32Shadow(Bitmap: TBitmap; Darkness: Byte=100);
var
I, J: Integer;
Pixels: PRGBQuad;
Color: COLORREF;
begin
for I := 0 to Bitmap.Height - 1 do
begin
Pixels := PRGBQuad(Bitmap.ScanLine[I]);
for J := 0 to Bitmap.Width - 1 do
begin
with Pixels^ do
begin
Color := RGB(rgbRed, rgbGreen, rgbBlue);
case Color of
$FFFFFF: rgbReserved := 0; // white = transparent
$000000: rgbReserved := 255; // black = opaque
else
rgbReserved := 255 - ((rgbRed + rgbGreen + rgbBlue) div 3); // intensity of semi transparent
end;
rgbRed := Darkness; rgbGreen := Darkness; rgbBlue := Darkness; // darkness
// pre-multiply the pixel with its alpha channel
rgbRed := (rgbRed * rgbReserved) div $FF;
rgbGreen := (rgbGreen * rgbReserved) div $FF;
rgbBlue := (rgbBlue * rgbReserved) div $FF;
end;
Inc(Pixels);
end;
end;
end;
{$IFDEF VER130} // D5
const
AC_SRC_ALPHA = $01;
{$ENDIF}
procedure TShadowBox.Paint;
var
Bitmap: TBitmap;
BlendFunction: TBlendFunction;
begin
Bitmap := TBitmap.Create;
try
Bitmap.PixelFormat := pf24bit;
Bitmap.Width := Width;
Bitmap.Height := Height;
Bitmap.Canvas.Pen.Color := clBlack;
Bitmap.Canvas.Brush.Color := clBlack;
Bitmap.Canvas.RoundRect(5, 5, Width - 5, Height - 5, 10, 10);
GBlur(Bitmap, 3); // Radius
Bitmap.PixelFormat := pf32bit;
Bitmap.IgnorePalette := True;
Bitmap.HandleType := bmDIB;
PrepareBitmap32Shadow(Bitmap, 150); // Darkness
BlendFunction.BlendOp := AC_SRC_OVER;
BlendFunction.BlendFlags := 0;
BlendFunction.SourceConstantAlpha := 255;
BlendFunction.AlphaFormat := AC_SRC_ALPHA;
Windows.AlphaBlend(
Canvas.Handle, // HDC hdcDest
0, // int xoriginDest
0, // int yoriginDest
Bitmap.Width, // int wDest
Bitmap.Height, // int hDest
Bitmap.Canvas.Handle, // HDC hdcSrc
0, // int xoriginSrc
0, // int yoriginSrc
Bitmap.Width, // int wSrc
Bitmap.Height, // int hSrc
BlendFunction); // BLENDFUNCTION
finally
Bitmap.Free;
end;
end;
end.
Usage:
uses ShadowBox;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
with TShadowBox.Create(Self) do
Control := Edit1;
with TShadowBox.Create(Self) do
Control := Shape1;
with TShadowBox.Create(Self) do
Control := Panel1;
end;