Delphi VCL ShadowEffect like FMX TShadowEffect

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;