unit ScrollListbox;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, extctrls,transhint,types;

type tmatrix = record
x1,y1,x2,y2 : integer;
item : integer;
end;

type TScrollListItemAdditonalInfo = class (TObject)
  private
   FAlbumNumber : integer;
   FTrackNumber : integer;
   FImage : tobject;
   icon : string;
  public
  property AlbumNumber : integer read FAlbumNumber write FAlbumNumber;
  property TrackNumber : integer read FTrackNumber write FTrackNumber;
  property picture : tobject read FImage write FImage;
  end;


type
  Treachedtop = procedure() of object;
  Treachedend = procedure() of object;
  TScrollListbox = class(TCustomControl)
  private
  cachedimage : tbitmap;
  addinfo : array of TScrollListItemAdditonalInfo;
  addinfocount : integer;
  upnormal,uppressed,downnormal,downpressed : tbitmap;
  fremote : boolean;
  fitems : tstringlist;
  fcount : integer;
  fitemindex : integer;
  fcolor : Tcolor;
  ffont : tfont;
  flinespacing : single;
  fmargin : integer;
  fnumbercolor : tcolor;
  fshownumbers : boolean;
  ftopmost : integer;
  fdisplayitems : integer;
  itemheight : integer;
  topborder : integer;
  fdrawmode : boolean;
  isdown : boolean;
  matrix : array of tmatrix;
  marked : integer;
  repeattimer : ttimer;
  xx,yy : integer;
  clicked : boolean;
  remoteused : boolean;
  fscalescrolls : real;
  fscrollwidths : integer;
  freachedend : Treachedend;
  freachedtop : Treachedtop;
  finmotion : boolean;
  Fitemhint : TTransparentHint;
  fhighlight : boolean;
  fhighlighteditem : integer;
  fhighlightcolor : tcolor;
  fhighlight2 : boolean;
  fhighlighteditem2 : integer;
  fhighlightcolor2 : tcolor;
  fmoretext : string;
  fmorebackgroundcolor: tcolor;
  procedure repeattimertimer(sender : tobject);
  procedure setcolor(_color : tcolor);
  procedure setfont(_font : tfont);
  procedure setlinespacing(_value : single);
  function cliptextout(buffer : Tbitmap;x,y : integer;st : string;no : integer;var numberextent : integer) : Tsize;
  procedure itemschange(sender : tobject);
  procedure setscrollwidths(sw : integer);
    procedure settopmost(i : integer);
  { Private declarations }
  protected
    { Protected declarations }
  public
  constructor Create(AOwner : TComponent); override;
  destructor Destroy; override;
  procedure Paint; override;
  procedure Resize; override;
  procedure MouseUp(Button: TMouseButton; Shift: TShiftState;X, Y: Integer);override;
  procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  procedure Click; override;
  procedure MouseDown(Button: TMouseButton; Shift: TShiftState;X, Y: Integer);override;
  procedure StopFlicker(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
  procedure setitemindex(i : integer);

  procedure scrollup;
  procedure scrolldown;
  procedure losefocus;
  procedure remoteclick;



    { Public declarations }
  published
  procedure additemandinfo(s : string;album : integer;track : integer;picture : tobject;icon : string;data : string);
  property color : Tcolor read Fcolor write setcolor default clred;
  property items : tstringlist read fitems;// write setitems;
  property itemindex : integer read fitemindex write setitemindex;
  property font : tfont read ffont write setfont;
  property linespacing : single read flinespacing write setlinespacing;
  property margin : integer read fmargin write fmargin;
  property showlabels : boolean read fshownumbers write fshownumbers;
  property drawmode : boolean read fdrawmode write fdrawmode;
  property numbercolor : tcolor read fnumbercolor write fnumbercolor;
  property morebackgroundcolor : tcolor read fmorebackgroundcolor write fmorebackgroundcolor;
  property OnClick;
  property count : integer read fcount;
  property remote : boolean read fremote write fremote;
  property scrollwidths : integer read fscrollwidths write setscrollwidths;
  property OnReachedend : TReachedend read freachedend write freachedend;
  property OnReachedtop : TReachedtop read freachedtop write freachedtop;
  property inmotion : boolean read finmotion write finmotion;
  procedure clear;
  procedure scrolltoend;
  property itemhint : TTransparentHint read Fitemhint write Fitemhint;
  property highlightindex : boolean read fhighlight write fhighlight;
  property highlightcolor : tcolor write fhighlightcolor;
  property highlighteditem : integer read fhighlighteditem write fhighlighteditem;
  property highlightindex2 : boolean read fhighlight2 write fhighlight2;
  property highlightcolor2 : tcolor write fhighlightcolor2;
  property highlighteditem2 : integer read fhighlighteditem2 write fhighlighteditem2;

  property topmost : integer read ftopmost write settopmost;
  property displayitems : integer read fdisplayitems;
  property moretext : string read fmoretext write fmoretext;
      { Published declarations }
  end;

const
TIMERINTERVAL=250;

procedure Register;



implementation
{$R ICONS.RES}

procedure Tscrolllistbox.settopmost(i : integer);
begin
//outputdebugstring(pchar('Tscrolllistbox settopmost: '+inttostr(i)+' - '+inttostr(items.count)));
if (i<0) then i:=highlighteditem-(fdisplayitems div 2);
if (i<items.count-1) and (i>0) then ftopmost:=i;
paint;
end;



procedure Tscrolllistbox.setscrollwidths(sw : integer);
var
obmp,bmp : tbitmap;
procedure scaleicon;
var
tr : trect;
begin
fscalescrolls:=fscrollwidths / bmp.width;
obmp.width:=round(bmp.width*fscalescrolls);
obmp.height:=round(bmp.height*fscalescrolls);

tr.top:=0;
tr.left:=0;
tr.Right:=obmp.width;
tr.Bottom:=obmp.height;
obmp.Canvas.StretchDraw(tr,bmp);
bmp.assign(obmp);
end;


begin

fscrollwidths:=sw;

bmp:=tbitmap.create;
obmp:=tbitmap.create;
bmp.LoadFromResourceName(hinstance,'UPPRESSED');
//scaleicon;
uppressed.assign(bmp);
bmp.free;
obmp.free;

bmp:=tbitmap.create;
obmp:=tbitmap.create;
bmp.LoadFromResourceName(hinstance,'UPNORMAL');
//scaleicon;
upnormal.assign(bmp);
bmp.free;
obmp.free;

bmp:=tbitmap.create;
obmp:=tbitmap.create;
bmp.LoadFromResourceName(hinstance,'DOWNPRESSED');
//scaleicon;
downpressed.assign(bmp);
bmp.free;
obmp.free;


bmp:=tbitmap.create;
obmp:=tbitmap.create;
bmp.LoadFromResourceName(hinstance,'DOWNNORMAL');
//scaleicon;
downnormal.assign(bmp);
bmp.free;
obmp.free;

end;

procedure Tscrolllistbox.losefocus;
begin
topmost:=0;
fitemindex:=-1;
marked:=-3;
repaint;

end;

procedure TScrollListbox.scrollup;
begin
if marked =0 then begin
  if Assigned(FReachedTop) then FReachedTop;
  exit;
end;

isdown:=true;
if marked<0 then marked:=topmost+1;
if marked>=1 then begin
   dec(marked);
   if (marked <= topmost) or (marked>topmost+fdisplayitems) then topmost:=marked;
  if marked<fitems.Count then fitemindex:=marked;
  remoteused:=true;
  repaint;
  exit;
end;
fitemindex:=marked;
remoteused:=true;
repaint;
end;

procedure TScrollListbox.scrolltoend;
begin
topmost:=(fitems.count)-fdisplayitems;
marked:=fitems.count-1;
repaint;
end;

procedure TscrollListbox.scrolldown;
begin;
isdown:=true;
if marked<0 then begin
   marked:=topmost-1;
end;


if marked+1=fitems.count then begin
  if Assigned(FReachedEnd) then FReachedEnd;
  repaint;
  exit;
end;

if marked<fitems.count-1 then begin
   inc(marked);
   if (marked < topmost) or (marked>=(topmost+fdisplayitems)) then begin
       topmost:=marked-fdisplayitems+1;
   end;
end;



fitemindex:=marked;
remoteused:=true;
repaint;
end;

procedure TscrollListbox.remoteclick;
begin
itemindex:=marked;
onclick(self);
end;


procedure TScrollListbox.setitemindex(i : integer);
begin
fitemindex:=i;
end;

procedure TScrollListbox.itemschange(sender : tobject);
begin
if items.count<=fdisplayitems+2 then paint;
end;

function TScrollListbox.cliptextout(buffer: TBitmap;x,y : integer;st : string;no : integer;var numberextent : integer) : Tsize;
var
ns : string;
ls : tsize;
o : tbitmap;
tr : trect;
iconsize,iconspace : integer;
begin
ls.cx:=0;
with buffer do begin

ns:=format('%.3d',[no]);

canvas.Brush.Style:=bsClear;

if fshownumbers=true then begin
   canvas.pen.color:=fnumbercolor;
   //canvas.rectangle(x,y,ls.cx,ls.cy);
  ls:=canvas.textextent(ns);
  ls.cx:=ls.cx+(width div 20);
  canvas.textout(x,y,ns);
end;


if fitems.objects[no-1]<>nil then begin
  if TScrollListItemAdditonalInfo(fitems.objects[no-1]).picture<>nil then begin
    tr.Left:=width-(itemheight);
    tr.top:=y-(itemheight div 2);
    tr.right:=width;
    tr.Bottom:=y+(itemheight div 2);
    try
    canvas.StretchDraw(tr,TBitmap(TScrollListItemAdditonalInfo(fitems.objects[no-1]).picture));
    canvas.Pen.color:=clblack;
    canvas.Rectangle(tr);
    except
    end;
  end;

  iconspace:=round(15*(screen.height/600));
  iconsize:=round(12*(screen.height/600));

  if TScrollListItemAdditonalInfo(fitems.objects[no-1]).icon<>'' then begin
    o:=tbitmap.create;
    ls.cx:=ls.cx+iconspace+10;
    o.LoadFromResourceName(hinstance,TScrollListItemAdditonalInfo(fitems.objects[no-1]).icon);
    tr.Left:=10;
    tr.top:=y;
    tr.Bottom:=y+iconsize;
    tr.Right:=tr.bottom-tr.top+10;
    canvas.Brush.Color:=clBlack;
    canvas.BrushCopy(tr,o,o.Canvas.ClipRect,rgb(255,0,0));
    canvas.Brush.Color:=fnumbercolor;
    //canvas.StretchDraw(tr,o);
    o.free;
  end;


end;


numberextent:=x+ls.cx;
canvas.textout(x+ls.cx,y,st);
result:=canvas.textextent(st);
result.cx:=result.cx+ls.cx;
end;
end;

procedure TScrolllistbox.clear;
var
  n: Integer;
begin
ftopmost :=0;
fitems.clear;
//repaint;
for n := 0 to addinfocount-1 do begin
if addinfo[n]<>nil then addinfo[n].Free;
end;
addinfocount:=0;
//repaint;
cachedimage.free;
cachedimage:=tbitmap.create;
fhighlighteditem:=-1;
fhighlighteditem2:=-1;

end;

procedure TScrolllistbox.setlinespacing(_value : single);
begin
if _value<1 then _value:=1;
flinespacing:=_value;
resize;
end;

procedure TScrolllistbox.setfont(_font : tfont);
begin
ffont.name:=_font.name;
ffont.size:=_font.size;
ffont.style:=_font.style;
end;


procedure TScrolllistbox.setcolor(_color : tcolor);
begin
Fcolor:=_color;
end;

constructor TScrollListbox.Create(AOwner : TComponent);
begin
     inherited;

     upnormal:=tbitmap.create;
     uppressed:=tbitmap.create;
     downnormal:=tbitmap.create;
     downpressed :=tbitmap.create;



     Fitemhint:=nil;
     fcolor:=clWindow;
     fitems:=tstringlist.create;
     fitems.OnChange:=itemschange;
     fitems.add(name);

     ffont:=tfont.create;
     //fmorebackgroundcolor:=rgb(230,230,230);
     fmorebackgroundcolor:=rgb($FD,$F7,$B5);
     fmoretext:='MORE';
     ffont.name:='arial';
     ffont.size:=12;
     flinespacing:=1;
     marked:=-3;
     topmost:=0;
     Parent := (AOwner AS TWinControl);

     canvas.pen.style:=psSolid;
     canvas.brush.style:=bsSolid;
     fshownumbers:=true;
     drawmode :=true;
     repeattimer:=ttimer.create(self);
     repeattimer.interval:=TIMERINTERVAL;
     repeattimer.ontimer:=repeattimertimer;
     repeattimer.enabled:=false;
     scrollwidths:=18;
     cachedimage:=tbitmap.create;
     fhighlight:=false;
     fhighlight2:=false;



end;


destructor TScrollListbox.Destroy;
begin
  inherited;
  clear;
  cachedimage.free;
  uppressed.Free;
  downpressed.Free;
  upnormal.Free;
  downnormal.Free;
end;

procedure TScrollListbox.Paint;
var
n : integer;
y : integer;
ext : Tsize;
max : integer;
showtop,showbottom : boolean;
tr,dr : trect;
bmp : Tbitmap;
vcanv : tbitmap;
ptp : Tpoint;
ne : integer;
fontcol : tcolor;



begin
inherited;
if parent=nil then exit;

if fdrawmode=false then begin
exit;
end;

if inmotion=true  then if cachedimage.empty=false then begin
  canvas.Draw(0,0,cachedimage);
  exit;
  end;


{ TODO -ojukebox -cvisual bug : LSB items sometimes add blank line }
vcanv:=tbitmap.Create;
vcanv.width:=width;
vcanv.height:=height;

vcanv.canvas.brush.assign(Canvas.brush);
vcanv.canvas.pen.Assign(Canvas.pen);
vcanv.canvas.font.assign(canvas.font);
fontcol:=canvas.font.color;


cachedimage.free;
cachedimage:=tbitmap.create;


with vcanv do begin
setlength(matrix,0);
if topmost=0 then showtop:=false else showtop:=true;
showbottom:=true;

canvas.Brush.color:=fcolor;
canvas.pen.color:=fcolor;
if drawmode=true then  canvas.Rectangle(0,0,width,height);

setlength(matrix,fitems.count+2);

y:=topborder;
max:=(topmost+fdisplayitems)-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 begin
        canvas.font.size:=round(ffont.size*1.5);
        end else begin
          canvas.font.size:=ffont.size;
        end;



if drawmode=true then if (marked=n) then
      begin
       ext:=cliptextout(vcanv,fmargin,y-(round(ffont.size*1.5) div 4),items[n],n+1,ne);
       ptp.x:=fmargin;
       ptp.y:=y;
       if assigned(fitemhint) then begin
       fitemhint.dohint(items[n]);
       fitemhint.Visible:=true;
       end;
      end else begin
       if (fhighlight=true) and ((n=fhighlighteditem) and (fhighlighteditem>-1)) then vcanv.canvas.font.color:=fhighlightcolor else vcanv.canvas.font.color:=fontcol;
       ext:=cliptextout(vcanv,fmargin,y,items[n],n+1,ne);
       if (fhighlight2=true) and ((n=fhighlighteditem2) and (fhighlighteditem2>-1)) then begin
       canvas.Pen.color:=clwhite;
        canvas.Rectangle(fmargin,y,(width),y+canvas.TextHeight(items[n]));
       end;

      end;


     matrix[n].x1:=fmargin;
     matrix[n].y1:=y;
     //matrix[n].x2:=matrix[n].x1+ext.cx;
     matrix[n].x2:=width;

     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.assign(uppressed) else bmp.assign(upnormal);

   canvas.font.Style:=[fsBold];
   canvas.font.size:=round(font.size * 0.6);//round(2*fscalescrolls);
   canvas.font.name:='arial';
   matrix[fitems.count].x1:=(width div 2) - (canvas.TextWidth(fmoretext) div 2)-4;
   matrix[fitems.count].y1:=-1;
   matrix[fitems.count].x2:=(width div 2) + (canvas.TextWidth(fmoretext) div 2)+4;
   matrix[fitems.count].y2:=1+(bmp.height)+canvas.textheight(fmoretext)+4;
   matrix[fitems.count].item:=-1;
   dr.left:=(width div 2)-(bmp.width div 2);//+fmargin;
   dr.top:=matrix[fitems.count].y1+2;
   dr.right:=bmp.width+dr.left;
   dr.bottom:=bmp.height+dr.Top;
   tr.top:=0;
   tr.left:=0;
   tr.right:=bmp.width;
   tr.Bottom:=bmp.height;
   //canvas.stretchdraw(dr,bmp);

   canvas.pen.color:=clgray;
   canvas.brush.Color:=fmorebackgroundcolor;
   canvas.Pen.Style:=psSolid;


   canvas.rectangle(matrix[fitems.count].x1,matrix[fitems.count].y1,matrix[fitems.count].x2,matrix[fitems.count].y2);
   canvas.BrushCopy(dr,bmp,tr,RGB(255,255,255));
   canvas.font.color:=clgray;
   canvas.textout(width div 2 - canvas.textwidth(fmoretext) div 2,matrix[fitems.count].y1+bmp.height+5,fmoretext);
   canvas.font.Style:=[];

   bmp.free;

 end;

if showbottom=true then begin

bmp:=tbitmap.create;
if marked=-2 then  bmp.assign(downpressed) else bmp.assign(downnormal);
   canvas.font.size:=round(font.size *0.6);//round(2*fscalescrolls);
   canvas.font.Style:=[fsBold];
   canvas.font.name:='arial';
   matrix[fitems.count+1].x1:=(width div 2) - (canvas.TextWidth(fmoretext) div 2)-4;
   matrix[fitems.count+1].y1:=(height-bmp.height-1)-canvas.textheight(fmoretext)-4;
   matrix[fitems.count+1].x2:=(width div 2) + (canvas.TextWidth(fmoretext) div 2)+4;
   matrix[fitems.count+1].y2:=height;
   matrix[fitems.count+1].item:=-2;
   dr.left:=(width div 2)-(bmp.width div 2);//+fmargin;
   dr.top:=matrix[fitems.count+1].y2-(bmp.height)-3;
   dr.right:=bmp.width+dr.left;
   dr.bottom:=bmp.height+dr.Top;
   tr.top:=0;
   tr.left:=0;
   tr.right:=bmp.width;
   tr.Bottom:=bmp.height;
   //canvas.stretchdraw(dr,bmp);

   canvas.pen.color:=clgray;
   canvas.brush.Color:=fmorebackgroundcolor;
   canvas.Pen.Style:=psSolid;

   canvas.rectangle(matrix[fitems.count+1].x1,matrix[fitems.count+1].y1,matrix[fitems.count+1].x2,matrix[fitems.count+1].y2);
   canvas.BrushCopy(dr,bmp,tr,RGB(255,255,255));
   canvas.font.color:=clgray;
   canvas.textout(width div 2 - canvas.textwidth(fmoretext) div 2,matrix[fitems.count+1].y1+1,fmoretext);
   canvas.font.Style:=[];


   bmp.free;
end;



end;
if (drawmode=true) then begin
try
  canvas.draw(0,0,vcanv);
  cachedimage.width:=width;
  cachedimage.Height:=height;
  cachedimage.canvas.Draw(0,0,vcanv);
except;
end;
end;
vcanv.free;

if clicked=true then begin
 clicked:=false;
 sleep(200);
 paint;
 end;



end;

procedure Register;
begin
  RegisterComponents('LibrarySmith', [TScrollListbox]);
end;


procedure TScrollListbox.Resize;
begin

canvas.Font:=ffont;
topborder:=itemheight+4;
itemheight:=round(canvas.textheight('AAA')*flinespacing);
fdisplayitems:=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
if fitemhint<>nil then fitemhint.Visible:=false;

clicked:=false;
isdown:=false;
fitemindex:=-1;
marked:=-3;
repeattimer.enabled:=false;
repeattimer.interval:=TIMERINTERVAL;
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>=0 then begin;
                                      fitemindex:=matrix[n].item;
                                      clicked:=true;
                                      fhighlighteditem:=n;
                                      end;
                                   repaint;
                                   inherited click;


                                   exit;
                               end;
end;
marked:=-3;
repaint;
end;

procedure TScrollListbox.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
n : integer;
begin
isdown:=true;
repeattimer.enabled:=true;
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
                               marked:=matrix[n].item;
                                if (matrix[n].item=-2) and (topmost<items.count) then inc(ftopmost);
                                if matrix[n].item=-1 then dec(ftopmost);
                                if (marked<0) and (fitemhint<>nil) then fitemhint.Visible:=false;
                               repaint;
                               exit;
                              end;

end;
end;

procedure TScrollListbox.StopFlicker(var Msg: TWMEraseBkgnd);
begin
  Msg.Result := 1;
end;

procedure TScrollListbox.MouseMove(Shift: TShiftState; X, Y: Integer);
begin

if remoteused=true then begin
 isdown:=false;
 marked:=-3;
 remoteused:=false;
end;

xx:=x;
yy:=y;
if marked<0 then exit;
if isdown=true then mousedown(tmousebutton(0),shift,x,y);
end;


procedure TScrollListbox.repeattimertimer(sender : tobject);
begin
mousedown(tmousebutton(0),[],xx,yy);
//sendmessage(self.handle,WM_LBUTTONDOWN,xx,yy);
if repeattimer.interval>20 then repeattimer.interval:=repeattimer.interval-10;
end;


procedure TScrollListbox.additemandinfo(s : string;album : integer;track : integer;picture : tobject;icon : string;data : string);
begin
  inc(addinfocount);
  setlength(addinfo,addinfocount);
  items.Add(s);
  addinfo[addinfocount-1]:=TScrollListItemAdditonalInfo.Create;
  addinfo[addinfocount-1].AlbumNumber:=album;
  addinfo[addinfocount-1].TrackNumber:=track;
  addinfo[addinfocount-1].picture:=picture;
  addinfo[addinfocount-1].icon:=icon;
  items.Objects[items.Count-1]:=addinfo[addinfocount-1];
end;
end.