unit TPictureScrollLb;

interface

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

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


type

  Treachedtop = procedure() of object;
  Treachedend = procedure() of object;
  TPictureScrollListBox = class(TCustomControl)
  private
  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;
  topmost : integer;
  displayitems : 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;
  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) : Tsize;
  procedure itemschange(sender : tobject);
  procedure setscrollwidths(sw : 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 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;
  procedure settopmost(i : integer);



    { Public declarations }
  published
  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 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;
  procedure clear;
  procedure scrolltoend;
     { Published declarations }
  end;

const
TIMERINTERVAL=250;

procedure Register;



implementation
{$R ICONS.RES}

procedure TPictureScrollListBox.settopmost(i : integer);
begin
topmost:=i;
paint;
end;



procedure TPictureScrollListBox.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 TPictureScrollListBox.losefocus;
begin
topmost:=0;
fitemindex:=-1;
marked:=-3;
repaint;

end;

procedure TPictureScrollListBox.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+displayitems) then topmost:=marked;
  fitemindex:=marked;
  remoteused:=true;
  repaint;
  exit;
end;
fitemindex:=marked;
remoteused:=true;
repaint;
end;

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

procedure TPictureScrollListBox.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+displayitems)) then begin
       topmost:=marked-displayitems+1;
   end;
end;



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

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


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

procedure TPictureScrollListBox.itemschange(sender : tobject);
begin
//repaint;
end;

function TPictureScrollListBox.cliptextout(buffer: TBitmap;x,y : integer;st : string;no : integer) : Tsize;
var
ns : string;
ls : tsize;
begin
ls.cx:=0;
with buffer do begin
if fshownumbers=true then begin
   ns:=format('%.3d',[no]);
   ls:=canvas.textextent(ns);
   canvas.brush.color:=fnumbercolor;
   //canvas.rectangle(x,y,ls.cx,ls.cy);
   ls.cx:=ls.cx+(width div 20);
   canvas.textout(x,y,ns);
   canvas.brush.color:=fcolor;
end;
canvas.textout(x+ls.cx,y,st);
result:=canvas.textextent(st);
result.cx:=result.cx+ls.cx;
end;
end;

procedure TPictureScrollListBox.clear;
begin
topmost :=0;
fitems.clear;
//repaint;
end;

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

procedure TPictureScrollListBox.setfont(_font : tfont);
begin
ffont:=font;
end;


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

constructor TPictureScrollListBox.Create(AOwner : TComponent);
begin
     upnormal:=tbitmap.create;
     uppressed:=tbitmap.create;
     downnormal:=tbitmap.create;
     downpressed :=tbitmap.create;

     inherited;

     fcolor:=clWindow;
     fitems:=tstringlist.create;
     fitems.OnChange:=itemschange;
     fitems.add(name);
     ffont:=tfont.create;
     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;



end;


procedure TPictureScrollListBox.Paint;
var
n : integer;
y : integer;
ext : Tsize;
max : integer;
showtop,showbottom : boolean;
vcanv : Tbitmap;
tr,dr : trect;
bmp : Tbitmap;





begin
if fdrawmode=false then begin
exit;
end;

vcanv:= Tbitmap.create;
vcanv.width:=width;
vcanv.height:=height;
vcanv.canvas.brush:=Canvas.brush;
vcanv.canvas.pen:=Canvas.pen;
vcanv.canvas.font:=canvas.font;


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+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.size:=round(ffont.size*1.5) else canvas.font.size:=ffont.size;


if drawmode=true then  if (marked=n) then ext:=cliptextout(vcanv,fmargin,y-(round(ffont.size*1.5) div 4),items[n],n+1) else ext:=cliptextout(vcanv,fmargin,y,items[n],n+1);

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

   matrix[fitems.count].x1:=(width div 2)-(bmp.width div 2)+fmargin;
   matrix[fitems.count].y1:=1;
   matrix[fitems.count].x2:=matrix[fitems.count].x1+bmp.width+fmargin;
   matrix[fitems.count].y2:=matrix[fitems.count].y1+bmp.height;
   matrix[fitems.count].item:=-1;


   dr.left:=matrix[fitems.count].x1;
   dr.top:=matrix[fitems.count].y1;
   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.BrushCopy(dr,bmp,tr,RGB(255,255,255));

   canvas.font.size:=round(7*fscalescrolls);
   canvas.font.name:='arial';
   canvas.font.color:=clgray;
   canvas.textout(width div 2 - canvas.textwidth('More') div 2,tr.top+(tr.bottom)+2,'More');
  bmp.free;
 end;

if showbottom=true then begin

bmp:=tbitmap.create;
if marked=-2 then  bmp.assign(downpressed) else bmp.assign(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;
   dr.left:=matrix[fitems.count+1].x1;
   dr.top:=matrix[fitems.count+1].y1;
   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.BrushCopy(dr,bmp,tr,RGB(255,255,255));
   canvas.font.size:=round(7*fscalescrolls);
   canvas.font.name:='arial';
   canvas.font.color:=clgray;
   canvas.textout(width div 2 - canvas.textwidth('More') div 2,dr.top-canvas.textheight('More'),'More');
   bmp.free;
end;



end;
if drawmode=true then canvas.draw(0,0,vcanv);
vcanv.free;

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


end;

procedure Register;
begin
  RegisterComponents('Samples', [TPictureScrollListBox]);
end;


procedure TPictureScrollListBox.Resize;
begin
canvas.Font:=ffont;
topborder:=itemheight;
itemheight:=round(canvas.textheight('AAA')*flinespacing);
displayitems:=round((height-topborder*2) / (itemheight));
end;

procedure TPictureScrollListBox.click;
begin
//inherited click;
end;

procedure TPictureScrollListBox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
n : integer;
begin
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;
                                      end;
                                   repaint;
                                   inherited click;

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

procedure TPictureScrollListBox.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 then inc(topmost);
                                  if matrix[n].item=-1 then dec(topmost);
                               repaint;
                               exit;
                              end;

end;
end;

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

procedure TPictureScrollListBox.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 TPictureScrollListBox.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;
end.