type 
  wie = (mittedick, obendick, untendick, normal); 
  lage = -10..10; 
 
const 
  oben = 5; 
 
var 
  txt: string; 
  abstand, lang, mitte, groesse: integer; 
  art: wie = mittedick; // bestimmt das Aussehen 
 
  schraeg: lage = 0; // positive Werte = nach unten rechts; 
                     // negative Werte = nach unten links; 
                     // 0 = senkrecht nach unten 
 
  welcher: integer = 0; // welcher Buchstabe wird gerade gezeigt 
  anzahl: integer = 14; // Buchstaben, die gleichzeitig zu sehen sind 
  links: integer = 25; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  txt := 'Das ist eine senkrechte Laufschrift zu Testzwecken     '; 
  lang := length(txt); 
  if anzahl > lang then anzahl := lang; 
  mitte := anzahl div 2; 
  txt := txt + txt; 
  Timer1.interval := 400; // nicht zu schnell!!! 
  canvas.brush.color := color; 
  canvas.brush.style := bsSolid; 
  canvas.font.color := clred; 
  canvas.font.name := 'Courier New'; // feste Breite empfohlen 
  canvas.font.style := [fsbold]; 
  if schraeg < 0 then dec(links, schraeg * anzahl); 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
var x, diff: integer; 
begin 
  inc(welcher); 
  if welcher > lang then welcher := 1; 
  abstand := 0; 
  case art of 
    normal: groesse := 16; 
    obendick: groesse := 22; 
  else groesse := 9; 
  end; 
  for x := 0 to anzahl - 1 do begin 
    canvas.font.size := groesse; 
    diff := groesse div 4; // leichte Korrektur des Aussehens 
    canvas.textout(schraeg * x + links - 5 - diff, oben + abstand, 
      #32#32#32#32#32); 
    canvas.textout(schraeg * x + links - diff, oben + abstand, 
      txt[welcher + x]); 
    abstand := abstand + canvas.textheight(txt); 
    case art of 
      mittedick: if x < mitte then inc(groesse, 2) else dec(groesse, 2); 
      obendick: dec(groesse); 
      untendick: inc(groesse); 
    end; 
  end; 
end;

const 
  links = 20; 
  geschw = 100; 
  warten = 1000; 
  weg = #32#32#32#32#32; // bei fester Breite reichen zwei Zeichen 
 
var 
  farbwechsel: boolean = true; 
  hoch, unten, merk: integer; 
  farbe: TColor = clblue; 
  welches: integer = 0; // welches Wort 
  wieviel: integer = 1; // wieviel Buchstaben werden angezeigt 
  anzahl: integer = 0; 
  sl: Tstringlist; 
  txt: string; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var x, lg: integer; 
begin 
  sl := Tstringlist.create; 
  txt := 'Diese Laufschrift besteht aus mehreren Worten'; 
  canvas.brush.color := color; 
  canvas.brush.style := bsSolid; 
  canvas.font.color := farbe; 
  canvas.font.name := 'Courier New'; // feste Breite empfohlen 
  canvas.font.style := [fsbold]; 
  canvas.font.size := 20; 
  hoch := canvas.textheight(txt); 
  sl.commatext := txt; 
  anzahl := 0; 
  for x := 0 to sl.count - 1 do begin 
    lg := length(sl[x]); 
    if anzahl < lg then anzahl := lg; 
  end; 
  unten := anzahl * hoch; 
  if unten + hoch > clientheight then 
    clientheight := unten + hoch 
  else unten := ((clientheight - hoch) div hoch) * hoch; 
  merk := unten; 
  Timer1.interval := geschw; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  sl.free; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
var x: integer; 
  zeit: longword; 
begin 
  for x := 0 to wieviel - 1 do begin 
    canvas.textout(links, unten + x * hoch, sl[welches][x + 1]); 
    canvas.textout(links - 5, unten + x * hoch + hoch, weg); 
  end; 
  dec(unten, hoch); 
  if wieviel = length(sl[welches]) then begin 
    if unten >= 0 then exit; 
    timer1.interval := 0; 
    zeit := gettickcount + warten; 
    repeat 
      application.processmessages; 
    until gettickcount >= zeit; 
    for x := 1 to length(sl[welches]) do 
      canvas.textout(links - 5, unten + x * hoch, weg); 
    wieviel := 1; 
    unten := merk; 
    inc(welches); 
    if welches = sl.count then begin 
      welches := 0; 
      zeit := gettickcount + warten; 
      refresh; 
      repeat 
        application.processmessages; 
      until gettickcount >= zeit; 
      if farbwechsel then begin 
        repeat 
          canvas.font.color := 
            RGB(random(2) * $FF, random(2) * $FF, random(2) * $FF); 
        until canvas.font.color <> farbe; 
        farbe := canvas.font.color; 
      end; 
    end; 
    Timer1.interval := geschw; 
  end else inc(wieviel); 
end;

type 
  TTMein = class(TThread) 
    procedure Execute; override; 
    procedure doit; 
  end; 
 
var 
  rc: TRect; 
  bm: TBitmap; 
  txt: string; 
  TMein: TTMein; 
  hoch, mitte, breit, buchst, anzahl, ausschnitt, stelle: integer; 
 
const 
  rand = 3; 
  links = 10; 
  geschw = 15; 
 
procedure TTMein.doit; 
begin 
  form1.canvas.copyrect(rc, bm.canvas, rect(0, stelle, breit, 
    stelle + ausschnitt)); 
  inc(stelle); 
  if stelle = mitte then stelle := 0; 
end; 
 
procedure TTMein.Execute; 
var zeit: cardinal; 
begin 
  repeat 
    synchronize(doit); 
    zeit := gettickcount + geschw; 
    repeat 
    until gettickcount >= zeit; 
  until false; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var x, y: integer; 
begin 
  bm := TBitmap.Create; 
  txt := '   Das ist eine senkrechte Laufschrift in einer Bitmap  '; 
  anzahl := length(txt); 
  with bm.canvas do begin 
    font.color := clnavy; 
    font.name := 'Courier New'; // empfohlen 
    font.style := [fsbold]; 
    font.size := 18; 
    buchst := textheight(txt); 
    mitte := buchst * anzahl; 
    breit := 0; 
    for x := 1 to length(txt) do begin      
      y := textwidth(txt[x]); 
      if y > breit then breit := y; 
    end; 
    inc(breit, 2 * rand); 
    txt := txt + txt; 
    inc(anzahl, anzahl); 
    hoch := buchst * anzahl; 
    bm.width := breit; 
    bm.height := hoch; 
    pen.style := psclear; 
    brush.color := color; // oder andere Farbe 
    fillrect(cliprect); 
    for x := 0 to anzahl - 1 do textout(rand, x * buchst, txt[x + 1]); 
  end; 
  ausschnitt := buchst * anzahl; 
  if ausschnitt > clientheight then 
    ausschnitt := clientheight; 
  stelle := 0; 
  rc := rect(links, 0, links + breit, ausschnitt); 
  TMein := TTMein.create(false); 
  TMein.priority := tpLower; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  TMein.suspend; 
  Application.processmessages; 
  TMein.free; 
  bm.free; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  if TMein.suspended then TMein.resume 
  else TMein.suspend; 
end;