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.