unit ScrollListbox; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TScrollListbox = class(TCustomControl) private fitems : tstringlist; fitemindex : integer; fcolor : Tcolor; ffont : tfont; flinespacing : single; fmargin : integer; procedure setitems(_items : tstringlist); procedure setcolor(_color : tcolor); procedure setfont(_font : tfont); procedure setlinespacing(_value : single); function cliptextout(x,y : integer;st : string) : Tsize; { Private declarations } protected { Protected declarations } public constructor Create(AOwner : TComponent); override; procedure Paint; override; procedure Resize; override; procedure Click; override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState;X, Y: Integer);override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState;X, Y: Integer);override; { Public declarations } published property color : Tcolor read Fcolor write setcolor default clred; property items : tstringlist read fitems write setitems; property itemindex : integer read fitemindex; property font : tfont read ffont write setfont; property linespacing : single read flinespacing write setlinespacing; property margin : integer read fmargin write fmargin; procedure clear; { Published declarations } end; procedure Register; implementation {$R ICONS.RES} type tmatrix = record x1,y1,x2,y2 : integer; item : integer; end; var topmost : integer; displayitems : integer; itemheight : integer; topborder : integer; matrix : array of tmatrix; marked : integer = -3; function TScrollListbox.cliptextout(x,y : integer;st : string) : Tsize; var sz : tsize; begin canvas.textout(x,y,st); result:=canvas.textextent(st); end; procedure TScrolllistbox.clear; begin fitems.clear; repaint; end; procedure TScrolllistbox.setlinespacing(_value : single); begin if _value<1 then _value:=1; flinespacing:=_value; resize; end; procedure TScrolllistbox.setfont(_font : tfont); begin ffont:=font; end; procedure TScrolllistbox.setitems(_items : tstringlist); begin fitems.assign(_items); end; procedure TScrolllistbox.setcolor(_color : tcolor); begin Fcolor:=_color; end; constructor TScrollListbox.Create(AOwner : TComponent); begin inherited; fcolor:=clWindow; fitems:=tstringlist.create; fitems.add(name); ffont:=tfont.create; ffont.name:='Arial'; ffont.size:=12; flinespacing:=1; topmost:=0; DoubleBuffered:=true; Parent := (AOwner AS TWinControl); fmargin:=width div 10; canvas.pen.style:=psSolid; canvas.brush.style:=bsSolid; end; procedure TScrollListbox.Paint; var n : integer; x,y : integer; ext : Tsize; bmp : tbitmap; max : integer; showtop,showbottom : boolean; rsnme : string; begin setlength(matrix,0); if topmost=0 then showtop:=false else showtop:=true; showbottom:=true; canvas.Brush.color:=fcolor; canvas.pen.color:=fcolor; canvas.Rectangle(0,0,width,height); setlength(matrix,fitems.count+2); y:=topborder; max:=(topmost+displayitems)-1; if max>=fitems.count-1 then begin max:=fitems.count-1; showbottom:=false; end; for n:=topmost to (max) do begin if marked=n then canvas.font.color:=clHighlight else canvas.font.color:=ffont.color; ext:=cliptextout(fmargin,y,fitems[n]); matrix[n].x1:=fmargin; matrix[n].y1:=y; matrix[n].x2:=matrix[n].x1+ext.cx; matrix[n].y2:=matrix[n].y1+ext.cy; matrix[n].item:=n; y:=y+itemheight; end; if showtop=true then begin bmp:=tbitmap.create; if marked=-1 then bmp.LoadFromResourceName(hinstance,'UPPRESSED') else bmp.LoadFromResourceName(hinstance,'UPNORMAL'); matrix[fitems.count].x1:=(width div 2)-(bmp.width div 2); matrix[fitems.count].y1:=1; matrix[fitems.count].x2:=matrix[fitems.count].x1+bmp.width; matrix[fitems.count].y2:=matrix[fitems.count].y1+bmp.height; matrix[fitems.count].item:=-1; canvas.Draw(matrix[fitems.count].x1,matrix[fitems.count].y1,bmp); bmp.free; end; if showbottom=true then begin bmp:=tbitmap.create; if marked=-2 then bmp.LoadFromResourceName(hinstance,'DOWNPRESSED') else bmp.LoadFromResourceName(hinstance,'DOWNNORMAL'); matrix[fitems.count+1].x1:=(width div 2)-(bmp.width div 2); matrix[fitems.count+1].y1:=height-bmp.height-1; matrix[fitems.count+1].x2:=matrix[fitems.count+1].x1+bmp.width; matrix[fitems.count+1].y2:=matrix[fitems.count+1].y1+bmp.height; matrix[fitems.count+1].item:=-2; canvas.Draw(matrix[fitems.count+1].x1,matrix[fitems.count+1].y1,bmp); bmp.free; end; end; procedure Register; begin RegisterComponents('Samples', [TScrollListbox]); end; procedure TScrollListbox.Resize; begin canvas.Font:=ffont; topborder:=itemheight; itemheight:=round(canvas.textheight('AAA')*flinespacing); displayitems:=round((height-topborder*2) / (itemheight)); end; procedure TScrollListbox.click; begin inherited click; end; procedure TScrollListbox.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var n : integer; begin marked:=-3; inherited MouseUp(Button,Shift,X,Y); for n:=0 to fitems.count+2 do begin if (x>=matrix[n].x1) And (x<=matrix[n].x2) And (y>=matrix[n].y1) And (y<=matrix[n].y2) then begin if matrix[n].item=-2 then inc(topmost); if matrix[n].item=-1 then dec(topmost); repaint; exit; end; end; end; procedure TScrollListbox.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var n : integer; begin inherited MouseDown(Button,Shift,X,Y); for n:=0 to fitems.count+2 do begin if (x>=matrix[n].x1) And (x<=matrix[n].x2) And (y>=matrix[n].y1) And (y<=matrix[n].y2) then begin if matrix[n].item>0 then fitemindex:=matrix[n].item; marked:=matrix[n].item; repaint; exit; end; end; end; end.