firemonkey - Delphi VCL ShadowEffect like FMX TShadowEffect -

in firemonkey can use tshadoweffect draw nice looking shadow.

this shadow adjusts opacity , translucency displays correct component beneath if control overlapping.

without tshadoweffect:

with tshadoweffect:

is there way draw same shadow effect in vcl forms without embedding fmx form?

my idea create tgraphiccontrol , place underneath target control. shadow control stick target control. steps of drawing shadow follow:

we create off screen bitmap , draw roundrect

then apply gaussian blur convolution kernel: see http://www.concepto.ch/delphi/uddf/pages/graphics.htm#graphics9 (unit gblur2). (edit: link dead)

finally make 32 bit alpha semi transparent gray scale. depending on amount of darkness:

and draw via alphablend on tgraphiccontrol canvas.

gblur2.pas (author unknown)

unit gblur2;  interface  uses   windows, graphics;  type   prgbtriple = ^trgbtriple;   trgbtriple = packed record     b: byte; {easier type 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 when using tkernel ignore weights except   weights in range -size..size.}  procedure gblur(thebitmap: tbitmap; radius: double);  implementation  uses   sysutils;  procedure makegaussiankernel(var k: tkernel; radius: double; maxdata, datagranularity: double); {makes k gaussian kernel standard deviation = radius. current application set maxdata = 255 , datagranularity = 1. procedure sets value of k.size when use k ignore weights small can't possibly matter. (small size because execution time going propertional k.size.)} var   j: integer;   temp, delta: double;   kernelsize: tkernelsize; begin   j := low(k.weights) high(k.weights)   begin     temp := j / radius;     k.weights[j] := exp(-temp * temp / 2);   end;   {now divide constant sum(weights) = 1:}   temp := 0;   j := low(k.weights) high(k.weights)     temp := temp + k.weights[j];   j := low(k.weights) high(k.weights)     k.weights[j] := k.weights[j] / temp;   {now discard (or rather mark ignorable setting size) entries small matter.   important, otherwise blur small radius take long large radius...}   kernelsize := maxkernelsize;   delta := datagranularity / (2 * maxdata);   temp := 0;   while (temp < delta) , (kernelsize > 1)   begin     temp := temp + 2 * k.weights[kernelsize];     dec(kernelsize);   end;   k.size := kernelsize;   {now correct go , jiggle again sum of entries we'll using 1}   temp := 0;   j := -k.size k.size     temp := temp + k.weights[j];   j := -k.size k.size     k.weights[j] := k.weights[j] / temp; end;  function trimint(lower, upper, theinteger: integer): integer; begin   if (theinteger <= upper) , (theinteger >= lower)     result := theinteger   else if theinteger > upper     result := upper   else     result := lower; end;  function trimreal(lower, upper: integer; x: double): integer; begin   if (x < upper) , (x >= lower)     result := trunc(x)   else if x > upper     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   j := 0 high(therow)   begin     tb := 0;     tg := 0;     tr := 0;     n := -k.size k.size     begin       w := k.weights[n];       {the trimint keeps running off edge of row...}       therow[trimint(0, high(therow), j - n)]       begin         tb := tb + w * b;         tg := tg + w * g;         tr := tr + w * r;       end;     end;     p[j]     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)     raise exception.create('gblur works 24-bit bitmaps');   makegaussiankernel(k, radius, 255, 1);   getmem(therows, thebitmap.height * sizeof(prow));   getmem(acol, thebitmap.height * sizeof(trgbtriple));   {record location of bitmap data:}   row := 0 thebitmap.height - 1     therows[row] := thebitmap.scanline[row];   {blur each row:}   p := allocmem(thebitmap.width * sizeof(trgbtriple));   row := 0 thebitmap.height - 1     blurrow(slice(therows[row]^, thebitmap.width), k, p);   {now blur each column}   reallocmem(p, thebitmap.height * sizeof(trgbtriple));   col := 0 thebitmap.width - 1   begin     {first read column trow:}     row := 0 thebitmap.height - 1       acol[row] := therows[row][col];     blurrow(slice(acol^, thebitmap.height), k, p);     {now put row, um, column data:}     row := 0 thebitmap.height - 1       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 exit;    if fcontrol <> acontrol   begin     if fcontrol <> nil     begin       fcontrol.windowproc := fcontrolwndproc;       fcontrol.removefreenotification(self);     end;     fcontrol := acontrol;     if fcontrol <> nil     begin       fcontrolwndproc := fcontrol.windowproc;       fcontrol.windowproc := controlwndproc;       fcontrol.freenotification(self);     end else       fcontrolwndproc := nil;     if fcontrol <> nil     begin       parent := fcontrol.parent;       adjustbounds;           end;   end; end;  procedure tshadowbox.controlwndproc(var message: tmessage); begin   if assigned(fcontrolwndproc)     fcontrolwndproc(message);   case message.msg of     cm_visiblechanged:       visible := fcontrol.visible;     wm_windowposchanged:       begin         if parent <> fcontrol.parent           parent := fcontrol.parent;         adjustbounds;       end;   end; end;  procedure tshadowbox.notification(acomponent: tcomponent; operation: toperation); begin   inherited;   if (operation = opremove) , (acomponent = fcontrol)   begin     fcontrol := nil;     fcontrolwndproc := nil;   end; end;  procedure tshadowbox.adjustbounds; begin   if fcontrol <> nil   begin     setbounds(fcontrol.left - 8, fcontrol.top - 8, fcontrol.width + 16, fcontrol.height + 16);     if fcontrol twincontrol       bringtofront     else       sendtoback;   end; end;  procedure preparebitmap32shadow(bitmap: tbitmap; darkness: byte=100); var   i, j: integer;   pixels: prgbquad;   color: colorref; begin   := 0 bitmap.height - 1   begin     pixels := prgbquad(bitmap.scanline[i]);     j := 0 bitmap.width - 1     begin       pixels^       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 pixel 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       bitmap.free;   end; end; end. 

usage:

uses shadowbox; ...  procedure tform1.formcreate(sender: tobject); begin   tshadowbox.create(self)     control := edit1;    tshadowbox.create(self)     control := shape1;    tshadowbox.create(self)     control := panel1; end;