unit textscroller; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, extctrls; const DEFAULTFONT='Garamond'; type TTextScroller = class(TCustomControl) private otimer : ttimer; ftext : string; otext : string; fspeed : integer; fcolor : Tcolor; ffont : tfont; frunning: boolean; spacerstring : string; ftop : integer; atimer : dword; fmesdone : TNotifyEvent; i : integer; fprepend : boolean; firstround : boolean; procedure setcolor(_color : tcolor); procedure setfont(_font : tfont); procedure state (state : boolean); procedure setspeed (speed : integer); procedure settext ( t : string); { Private declarations } protected { Protected declarations } public constructor Create(AOwner : TComponent); override; destructor Destroy; override; procedure Paint; override; procedure Resize; override; { Public declarations } published procedure timercall(Sender : Tobject); property prepend : boolean read fprepend write fprepend; property color : Tcolor read Fcolor write setcolor default clred; property font : tfont read ffont write setfont; property running : boolean read frunning write state; property speed : integer read fspeed write setspeed; property text : string read ftext write settext; property messagedone : TNotifyEvent read fmesdone write fmesdone; { Published declarations } end; procedure Register; implementation destructor TTextscroller.Destroy; begin otimer.enabled:=false; inherited destroy; end; procedure TTextScroller.settext(t : string); var te : boolean; begin try te:=otimer.enabled; otimer.enabled:=false; ftext:=t; resize; paint; otimer.enabled:=te; firstround:=true; except end; end; procedure TTextScroller.setfont(_font : tfont); begin ffont.Assign(_font); end; procedure TTextScroller.setcolor(_color : tcolor); begin Fcolor:=_color; canvas.brush.color:=fcolor; end; constructor TTextScroller.Create(AOwner : TComponent); begin inherited; Parent := (AOwner AS TWinControl); fcolor:=clWindow; ffont:=tfont.create; ffont.name:=DEFAULTFONT; ffont.size:=12; canvas.pen.style:=psSolid; canvas.brush.style:=bsSolid; otimer:=ttimer.create(nil); fspeed:=100; otimer.interval:=100; otimer.enabled:=false; otimer.OnTimer:=timercall; controlstyle:=controlstyle+[csOpaque]; end; procedure TTextScroller.Paint; var vcanv : Tbitmap; tr : trect; begin vcanv:= Tbitmap.create; vcanv.width:=width; vcanv.height:=height; vcanv.canvas.brush:=Canvas.brush; vcanv.canvas.pen:=Canvas.pen; vcanv.canvas.font:=ffont; with vcanv do begin tr.Left:=0; tr.Top:=0; tr.Right:=width; tr.Bottom:=height; canvas.fillrect(tr); if otext<>'' then canvas.textout(0,ftop,otext); end; canvas.draw(0,0,vcanv); vcanv.free; end; procedure Register; begin RegisterComponents('LibrarySmith', [TTextScroller]); end; procedure TTextScroller.Resize; var t : integer; ss : string; begin canvas.Font.assign(ffont); ss:=''; t:=0; while(t<width) do begin ss:=ss+' '; t:=canvas.textwidth(ss); end; ss:=copy(ss,1,length(ss)-2); spacerstring:=ss; if prepend=false then otext:=' '+ftext+spacerstring else otext:=spacerstring+' '+ftext; ftop:=canvas.textheight('M'); ftop:=(height div 2)-(ftop div 2); end; procedure TTextScroller.state(state : boolean); begin if state=true then otimer.enabled:=true else otimer.enabled:=false; resize; end; procedure TTextScroller.setspeed (speed : integer); begin otimer.interval:=speed; fspeed:=speed; end; procedure TTextScroller.timercall(Sender : Tobject); var fc : string; begin i:=i+1; if assigned(fmesdone) then if (pos(spacerstring,otext)=1) then begin if i>1 then if firstround=false then fmesdone(self); firstround:=false; i:=0; end; if ((gettickcount-atimer)>=otimer.interval) or (sender=otimer) then begin; fc:=otext[1]; otext:=copy(otext,2,length(otext)-1)+fc; paint; atimer:=gettickcount; end; end; end.