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;
Comments
Post a Comment