unit U_Lauftext;
interface
uses
Windows, Messages, Classes, Graphics,
Controls, ExtCtrls, SysUtils, forms;
type
TLauftext =
class(TGraphicControl)
private
Fbild: TBitmap;
FTextleft: integer;
FTimer: TTimer;
FParentHintergrund: TBitmap;
FNureinmal: boolean;
procedure OnTimer(Sender: TObject);
public
procedure Paint;
override;
constructor Create(NewParent: TWincontrol; newleft,newtop,breite,hoehe: integer);
reintroduce;
virtual;
destructor Destroy;
override;
end;
implementation
constructor TLauftext.Create(NewParent: TWincontrol; newleft,newtop,breite,hoehe: integer);
begin
inherited Create(NewParent);
parent := NewParent;
width := breite;
height := hoehe;
left := newleft;
top := newtop;
FBild := TBitmap.create;
FBild.Width := Width;
FBild.Height := Height;
FParentHintergrund := TBitmap.create;
FParentHintergrund.Width := width;
FParentHintergrund.Height := height;
FNureinmal := false;
FTimer := TTimer.create(self);
FTimer.Interval := 55;
FTimer.OnTimer := OnTimer;
FTimer.Enabled := true;
end;
destructor TLauftext.destroy;
begin
Fbild.Free;
FParentHintergrund.Free;
FTimer.free;
inherited;
end;
procedure TLauftext.OnTimer(Sender: TObject);
begin
IF FTextleft > fbild.Canvas.TextWidth('
test dsgfsgfksdgfsdfgsdfksfgdksdfgksdfg test!!!!!')
then
begin
FTextleft := -width;
end;
FTextleft:= FTextleft+1;
paint;
end;
procedure TLauftext.paint;
var
zspeicher:
string;
begin
inherited;
IF not FNureinmal
then BitBlt(FParentHintergrund.canvas.handle, 0, 0, Width, height, canvas.handle, 0, 0, srccopy);
FNureinmal := true;
//Hintergrund kopieren
BitBlt(fbild.canvas.handle, 0, 0, Width, height, FParentHintergrund.canvas.handle, 0, 0, srccopy);
fbild.Canvas.Brush.Style := bsclear;
fbild.Canvas.font.color := clred;
zspeicher := '
test dsgfsgfksdgfsdfgsdfksfgdksdfgksdfg test!!!!!';
fbild.Canvas.TextOut(0-FTextleft,1,zspeicher);
BitBlt(canvas.handle, 0, 0, Width, height, fbild.canvas.handle, 0, 0, srccopy);
end;
end.