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.