unit bitmapactionbutton; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, stdctrls; type tmatrix = record x1,y1,x2,y2 : integer; item : integer; end; type TBitmapActionButton = class(TGraphicControl) private fbuttoncolor : integer; fcolor : Tcolor; ftext : string; fdown : boolean; procedure autosize; procedure setcolor(_color : tcolor); procedure settext(txt : string); procedure setdown (check : boolean); { Private declarations } protected { Protected declarations } public constructor Create(AOwner : TComponent); override; procedure Paint; override; procedure Resize; override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState;X, Y: Integer);override; procedure Click; override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState;X, Y: Integer);override; procedure setbuttoncolor(c : integer); { Public declarations } published property color : Tcolor read Fcolor write setcolor default clred; property font; property parentfont; property caption : string read ftext write settext; property down : boolean read fdown write setdown; property buttoncolor : integer read fbuttoncolor write setbuttoncolor; property OnClick; property OnMouseDown; property OnMouseUp; property visible; { Published declarations } end; const ICONWIDTH = 32; procedure Register; implementation {$R ICONS.RES} procedure alphablendbitmapwithcolor(blend : tbitmap;blendcolor : tcolor;source : tbitmap;alpha : real); var x,y : integer; rin,rout : pbytearray; outval : integer; br,bg,bb : integer; function rangecheck(inp : integer) : byte; begin if inp>255 then outval:=255; if inp<0 then outval:=0; result:=byte(inp); end; begin source.width:=blend.width; source.height:=blend.height; source.pixelformat:=pf24bit; br:=getrvalue(ColorToRGB(blendcolor)); bg:=getgvalue(ColorToRGB(blendcolor)); bb:=getbvalue(ColorToRGB(blendcolor)); with source do begin for y:=0 to source.height -1 do begin rin:=scanline[y]; rout:=source.scanline[y]; x:=0; // application.processmessages; while x< 3*width-1 do begin // application.processmessages; outval:=round((alpha*(rin[x]-br))+br); rout[x]:=rangecheck(outval); // application.processmessages; outval:=round((alpha*(rin[x+1]-bg))+bg); rout[x+1]:=rangecheck(outval); // application.processmessages; outval:=round((alpha*(rin[x+2]-bb))+bb); rout[x+2]:=rangecheck(outval); x:=x+3; end; end; end; end; procedure TBitmapActionButton.autosize; begin canvas.font.name:=font.name; canvas.font.size:=font.size; if (canvas.textwidth(ftext)+ICONWIDTH+16)>=width then width:=(canvas.textwidth(caption)+ICONWIDTH+19); if (canvas.textheight(ftext))>=height then height:=(canvas.textheight(ftext)); if height<ICONWIDTH then height:=iconWIDTH; end; procedure TBitmapActionButton.setbuttoncolor(c : integer); begin fbuttoncolor:=c; invalidate; end; procedure TBitmapActionButton.setcolor(_color : tcolor); begin Fcolor:=_color; invalidate; end; procedure TBitmapActionButton.settext(txt : string); begin ftext:=txt; autosize; invalidate; end; procedure TBitmapActionButton.setdown(check: boolean); begin fdown:=check; invalidate; end; constructor TBitmapActionButton.Create(AOwner : TComponent); begin inherited Create(AOwner); controlstyle:=controlstyle-[csOpaque]; Parent := (AOwner AS TWinControl); fcolor:=clWindow; canvas.pen.style:=psSolid; height:=32; width:=50; fdown:=false; end; procedure TBitmapActionButton.Paint; var vicon : tbitmap; textcentre : integer; tr,dr : trect; bt : string; //vcanv : Tbitmap; begin inherited paint; canvas.brush.style:=bssolid; {vcanv:= Tbitmap.create; vcanv.width:=width; vcanv.height:=height; vcanv.canvas.brush:=Canvas.brush; vcanv.canvas.pen:=Canvas.pen; vcanv.canvas.font:=canvas.font; } vicon:=tbitmap.create; bt:='BLUE'; if fbuttoncolor=1 then bt:='GREEN'; if fbuttoncolor=2 then bt:='RED'; if fbuttoncolor=3 then bt:='PURPLE'; if fbuttoncolor=4 then bt:='YELLOW'; {tr.top:=0; tr.left:=0; tr.right:=width; tr.bottom:=height; vcanv.canvas.copyrect(tr,canvas,tr); } if fdown=true then begin vicon.loadfromresourcename(hinstance,bt+'DOWN'); end else vicon.loadfromresourcename(hinstance,bt+'UP'); if fbuttoncolor>5 then begin alphablendbitmapwithcolor(vicon,fbuttoncolor,vicon,0.4); end; tr.Left:=0; tr.Top:=0; tr.Right:=width; tr.Bottom:=height; //canvas.fillrect(tr); tr.Left:=0; tr.Top:=0; tr.Right:=vicon.width; tr.Bottom:=vicon.height; dr.Left:=2; dr.Top:=2; dr.Right:=vicon.width+2; dr.Bottom:=vicon.height; canvas.brush.style:=bsclear; //canvas.brushcopy(dr,vicon,tr,vicon.Canvas.Pixels[1,1]); canvas.brushcopy(dr,vicon,tr,rgb(255,255,255)); textcentre:=(height div 2) - (canvas.textheight(ftext) div 2); canvas.font.style:=font.style; canvas.font.name:=font.name; canvas.font.size:=font.size; canvas.font.color:=font.color; canvas.pen.color:={viewgit}{/viewgit}00C6F7; canvas.pen.width:=2; canvas.brush.style:=bsClear; canvas.Ellipse(2,2,tr.right+2,tr.bottom); canvas.textout(vicon.width+16,textcentre,ftext); vicon.free; end; procedure Register; begin RegisterComponents('LibrarySmith', [TBitmapActionButton]); end; procedure TBitmapActionButton.Resize; begin inherited resize; canvas.Font:=font; end; procedure TBitmapActionButton.click; begin inherited click; end; procedure TBitmapActionButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin fdown:=false; invalidate; inherited; end; procedure TBitmapActionButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin fdown:=true; invalidate; inherited; end; end.