Index
» Empathy Jukebox : Blob 1b69df / Standalone_Components / TPictureScrollListBox / TPictureScrollLb.pas
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.