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.