unit Unit1; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Graphics, Controls, Forms, 
  ExtCtrls; 
 
type 
  TForm1 = class(TForm) 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure FormPaint(Sender: TObject); 
  private 
{ Private-Deklarationen} 
  public 
    procedure lauf(sender: tobject); 
    procedure ausgabe; 
    function lesen: char; 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
const 
  geschw: integer = 150; 
  oben: integer = 5; 
  lang: integer = 25; 
  offen: boolean = false; 
  ZusatzLeerzeichenBeiZeilenEnde: integer = 10; 
  ZusatzLeerzeichenBeiTab: integer = 3; 
  zahl: integer = 0; 
  txt: string = #32#32#32#32#32#32#32#32; 
 
var 
  foc: file of char; 
  tt: TTimer; 
  links: integer; 
 
function TForm1.lesen: char; 
begin 
  if zahl > 0 then begin 
    dec(zahl); result := #32; exit; 
  end; 
  repeat 
    if eof(foc) then seek(foc, 0); 
    read(foc, result); 
    if result = #13 then zahl := ZusatzLeerzeichenBeiZeilenEnde 
    else if result = #9 then begin 
      zahl := ZusatzLeerzeichenBeiTab; 
      result := #32; 
    end else 
      if result < #32 then result := #32; 
  until result > #31; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  i: integer; 
begin 
  assignfile(foc, 'c:\autoexec.bat'); 
{$I-} 
  reset(foc); 
  if ioresult = 0 then begin 
    if filesize(foc) = 0 then begin 
      closefile(foc); 
      exit; 
    end; 
    offen := true; 
    for i := length(txt) to lang do begin 
      txt := txt + lesen; 
    end; 
    canvas.font.name := 'Fixedsys'; 
    canvas.font.color := claqua; 
    canvas.Brush.color := 0; 
    links := (width - canvas.textwidth(#32 + txt + #32)) div 2; 
    tt := TTimer.create(self); 
    tt.ontimer := lauf; 
    tt.interval := geschw; 
  end; 
{$I+} 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  if offen then begin 
    closefile(foc); 
    tt.free; 
    tt := nil; 
  end; 
end; 
 
procedure Tform1.ausgabe; 
begin 
  canvas.textout(links, oben, #32 + txt + #32); 
end; 
 
procedure TForm1.lauf(sender: tobject); 
begin 
  txt := copy(txt, 2, lang) + lesen; 
  ausgabe; 
end; 
 
procedure TForm1.FormPaint(Sender: TObject); 
begin 
  if offen then ausgabe; 
end; 
 
end. 
 

//------------------------------------------------------------------ 
 
// Variante 2: Smooth-Ticker 

// Dieses Programm erzeugt ein "weiches" Scrollen. Der Text wird aus einer 
// Textdatei gelesen. Allerdings darf pro Einzeltext kein Steuerzeichen 
// (also z.B. kein Tab) vorhanden sein. Absätze sind auch nicht erlaubt. 
// Ich nutze diesen Code um Witze aus einer Datei zu lesen und auf dem 
// Formular scrollen zu lassen. Das bedeutet, den Witz komplett ohne Zeilen- 
// unbruch und ohne Absatz in die Textdatei zu schreiben und erst am Ende des 
// Witzes einmal ENTER zu drücken. 

unit Laufs; 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  StdCtrls, ExtCtrls; 
 
type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure FormPaint(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
  private 
{ Private-Deklarationen} 
  public 
    procedure zeigen; 
    procedure weiter; 
    procedure schreiben; 
  end; 
 
var 
  Form1: TForm1; 
  bmp: TBitmap; 
  sl: TStringlist; 
  lg: array of integer; 
  rz: TRect; 
  txt: array[0..1] of integer; 
  leer: string; 
 
const 
  breite: integer = 300; // Breite des Laufschriftfeldes 
  links: integer = 100; // linke Kante der Laufschrift 
  oben: integer = 10; // obere Kante der Laufschrift 
  stelle: integer = 0; 
  farbe: integer = 0; 
  colours: array[0..6] of TColor = 
  (cllime, $BBDDFF, claqua, clyellow, $FF90FF, $FFA033, $00A0FF); 
 
  Farbwechsel: boolean = true; 
 
implementation 
 
{$R *.DFM} 
 
uses math; 
 
type 
  TMein = class(TThread) 
    procedure Execute; override; 
    procedure doit; 
  end; 
 
const 
  lauf: boolean = true; 
  geschw = 13; 
 
procedure TMein.doit; 
begin 
  Form1.zeigen; 
  inc(stelle); 
  if stelle > lg[txt[0]] then begin 
    stelle := 0; 
    Form1.weiter; 
  end; 
end; 
 
procedure TForm1.zeigen; 
begin 
  canvas.copyrect(rz, bmp.canvas, rect(stelle, 0, breite + stelle, bmp.height)); 
end; 
 
procedure TMein.Execute; 
var 
  zeit: longword; 
begin 
  repeat 
    if lauf then synchronize(doit); 
    zeit := gettickcount + geschw; 
    repeat 
    until gettickcount >= zeit; 
  until false; 
end; 
 
procedure TForm1.schreiben; 
begin 
  bmp.canvas.font.color := colours[farbe]; 
  bmp.canvas.TextOut(0, 1, leer + sl[txt[0]]); 
  if Farbwechsel then begin 
    inc(farbe); 
    if farbe = length(colours) then farbe := 0; 
    bmp.canvas.font.color := colours[farbe]; 
  end; 
  bmp.canvas.TextOut(lg[txt[0]], 1, leer + sl[txt[1]]); 
end; 
 
procedure TForm1.weiter; 
var 
  x: integer; 
begin 
  for x := 0 to 1 do begin 
    inc(txt[x]); 
    if txt[x] > sl.count - 1 then txt[x] := 0; 
  end; 
  schreiben; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  x, maxz, minz: integer; 
begin 
  leer := StringOfChar(#32, 18); 
  canvas.pen.color := clwhite; 
  bmp := tbitmap.create; 
  bmp.canvas.Brush.color := $404040; 
  bmp.canvas.font.name := 'Courier New'; 
  bmp.canvas.font.size := 9; 
  sl := TStringlist.create; 
  try 
    sl.loadfromfile('c:\witze.txt'); 
  except exit; end; 
  if sl.count = 0 then exit; 
  setlength(lg, sl.count); 
  maxz := 0; 
  minz := maxint; 
  for x := 0 to sl.count - 1 do begin 
    lg[x] := bmp.canvas.textwidth(sl[x] + leer); 
    maxz := max(lg[x], maxz); 
    minz := min(lg[x], minz); 
  end; 
  bmp.width := maxz * 2; 
  breite := min(minz, breite); 
  bmp.height := bmp.canvas.textheight(sl[0]) + 2; 
  bmp.Canvas.fillrect(bmp.canvas.cliprect); 
  rz := rect(links, oben, links + breite, oben + bmp.height); 
  txt[0] := 0; 
  txt[1] := ord(sl.count > 1); 
  schreiben; 
  TMein.create(false); 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  lg := nil; 
  bmp.free; 
  sl.free; 
end; 
 
procedure TForm1.FormPaint(Sender: TObject); 
const 
  rand = 2; 
begin 
  canvas.brush.color := bmp.canvas.brush.color; 
  canvas.fillrect(rect(links - rand, oben, links, oben + bmp.height)); 
  canvas.fillrect(rect(links + breite, oben, links + breite + rand, oben + bmp.height)); 
  canvas.brush.style := bsclear; 
  zeigen; 
  canvas.rectangle(links - 1 - rand, oben - 1, links + breite + 1 + rand, oben + bmp.height + 1); 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  lauf := not lauf; 
end; 
 
end.