unit numericinput; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, stdctrls,extctrls; const TIMERSTARTINTERVAL=200; type TNumericInput= class(TGraphicControl) private fcolor : Tcolor; fldown,frdown : boolean; minusup,minusdown,plusup,plusdown : tbitmap; fvalue : integer; fmax,fmin : integer; ftimer : TTimer; procedure setcolor(_color : tcolor); procedure setmin(min : integer); procedure setmax(max : integer); procedure setvalue(n : integer); { 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 MouseDown(Button: TMouseButton; Shift: TShiftState;X, Y: Integer);override; procedure dotimer(sender : tobject); { Public declarations } published property color : Tcolor read Fcolor write setcolor default clred; property font; property parentfont; property OnClick; property OnMouseDown; property OnMouseUp; property visible; property value : integer read fvalue write setvalue; property max : integer read fmax write setmax; property min : integer read fmin write setmin; { Published declarations } end; const ICONWIDTH = 32; procedure Register; implementation {$R ICONS.RES} procedure Tnumericinput.setvalue(n : integer); begin if n<=fmax then fvalue:=n; if n>=fmin then fvalue:=n; paint; end; procedure Tnumericinput.dotimer(sender : tobject); begin if frdown=true then if fvalue+1<=fmax then value:=value+1; if fldown=true then if fvalue-1>=fmin then value:=value-1; if ftimer.Interval>20 then ftimer.Interval:=ftimer.Interval-10; end; procedure Tnumericinput.setmax(max : integer); begin fmax:=max; if value>fmax then value:=fmax; end; procedure Tnumericinput.setmin(min : integer); begin fmin:=min; if value<fmin then value:=fmin; end; 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]-bb))+bb); 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]-br))+br); rout[x+2]:=rangecheck(outval); x:=x+3; end; end; end; end; procedure TNumericInput.setcolor(_color : tcolor); begin Fcolor:=_color; resize; invalidate; end; constructor TNumericInput.Create(AOwner : TComponent); begin inherited Create(AOwner); controlstyle:=controlstyle-[csOpaque]; Parent := (AOwner AS TWinControl); fcolor:=clWindow; canvas.pen.style:=psSolid; plusup:=tbitmap.Create; plusdown:=tbitmap.Create; minusup:=tbitmap.Create; minusdown:=tbitmap.Create; ftimer:=ttimer.create(self); ftimer.Enabled:=false; ftimer.Interval:=TIMERSTARTINTERVAL; ftimer.OnTimer:=dotimer; fmax:=100; fmin:=0; width:=200; end; procedure TNumericInput.Paint; var dr : trect; begin inherited paint; //vcanv:=tbitmap.create; //vcanv.SetSize(width,height); dr.left:=0; dr.right:=height; dr.Top:=0; dr.bottom:=dr.right; canvas.Brush.Style:=bsClear; if fldown=false then Canvas.BrushCopy(dr,minusup,minusup.Canvas.ClipRect,minusup.Canvas.Pixels[0,0]) else Canvas.BrushCopy(dr,minusdown,minusdown.Canvas.ClipRect,minusdown.Canvas.Pixels[0,0]); canvas.Font.Assign(font); canvas.Font.Size:=width div 7; canvas.Brush.Style:=bsSolid; canvas.Pen.color:=clWhite; canvas.Brush.color:=clBlack; canvas.Rectangle(dr.right+4,0,width-dr.Right-4,height); canvas.Brush.Style:=bsClear; canvas.TextOut((width div 2)-(canvas.textwidth(inttostr(fvalue)) div 2),height div 2 - canvas.TextHeight('A') div 2,inttostr(fvalue)); dr.left:=width - (dr.right); dr.Right:=width; if frdown=false then Canvas.BrushCopy(dr,plusup,plusup.Canvas.ClipRect,plusup.Canvas.Pixels[0,0]) else Canvas.BrushCopy(dr,plusdown,plusdown.Canvas.ClipRect,plusdown.Canvas.Pixels[0,0]); end; procedure Register; begin RegisterComponents('LibrarySmith', [TNumericInput]); end; procedure TNumericInput.Resize; begin height:=round(width / 4); inherited resize; canvas.Font:=font; plusup.LoadFromResourceName(hinstance,'PLUSUP'); plusdown.LoadFromResourceName(hinstance,'PLUSDOWN'); minusup.LoadFromResourceName(hinstance,'MINUSUP'); minusdown.LoadFromResourceName(hinstance,'MINUSDOWN'); alphablendbitmapwithcolor(plusup,fcolor,plusup,0.7); alphablendbitmapwithcolor(plusdown,fcolor,plusdown,0.7); alphablendbitmapwithcolor(minusup,fcolor,minusup,0.7); alphablendbitmapwithcolor(minusdown,fcolor,minusdown,0.7); end; procedure TNumericInput.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin invalidate; fldown:=false; frdown:=false; ftimer.enabled:=false; ftimer.Interval:=TIMERSTARTINTERVAL; inherited; end; procedure TNumericInput.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if (x<width div 3) then begin fldown:=true; if fvalue-1>=fmin then value:=value-1; end; if (x>width - (width div 3)) then begin frdown:=true; if fvalue+1<=fmax then value:=value+1; end; ftimer.enabled:=true; invalidate; inherited; end; end.