type 
  ausbl = (abLinks, abRechts, abBeide, abNichts); 
 
var 
  schrift: string = ' + + + Laufschrift'; 
  auslaufzone: integer = 60; 
  fontsize: integer = 10; 
  fase: integer = 0; 
  step: integer = 1; // empfohlen 
  fontname: string = 'MS Sans Serif'; 
  fontstyle: TFontstyles; 
  ausblendFarbe, hintergrund, schriftFarbe: TColor; 
  rh, gh, bh, ra, ga, ba: byte; 
  bm: TBitmap; 
  sbreite, links, oben: integer; 
  breite: integer = 0; // 0 = Schrift komplett anzeigen 
  wo: ausbl = abLinks; // welche Seite(n) 
  nachricht: boolean = True; // True = Abbruch bei Konfigurationsfehler 
 
procedure TForm1.config; 
var 
  size: TSize; 
begin 
  Timer1.enabled := false; 
  ausblendFarbe := colortorgb(ausblendFarbe); 
  hintergrund := colortorgb(hintergrund); 
  self.refresh; 
  with bm, bm.canvas do begin 
    pixelformat := pf24bit; 
    font.size := fontsize; 
    font.name := fontname; 
    font.style := fontstyle; 
    canvas.font.color := schriftFarbe; 
    size := TextExtent(schrift); 
    height := 3 + size.cy; 
    sbreite := size.cx + ord(fsItalic in fontstyle) * (fontsize div 5); 
    if breite = 0 then breite := sbreite 
    else if breite > sbreite then begin 
      if nachricht then 
        raise exception.create('Breite für Text zu groß!') 
      else breite := sbreite; 
    end; 
    width := breite; 
  end; 
  if fase <= -sbreite then fase := 0; 
  ra := getrvalue(ausblendFarbe); 
  ga := getgvalue(ausblendFarbe); 
  ba := getbvalue(ausblendFarbe); 
  rh := getrvalue(hintergrund); 
  gh := getgvalue(hintergrund); 
  bh := getbvalue(hintergrund); 
  if ((wo in [abLinks, abRechts]) and (bm.width < auslaufzone) 
    or (wo = abBeide) and (bm.width < auslaufzone * 2)) 
    then begin 
    if nachricht then 
      raise exception.create('Auslaufzone zu groß!'); 
  end else Timer1.enabled := true; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  bm := TBitmap.create; 
  hintergrund := color; 
  ausblendFarbe := hintergrund; 
  schriftfarbe := clGreen; 
  fontstyle := []; 
  links := 100; 
  oben := 20; 
  config; // immer zu Anfang (nach Festlegung von Werten) aufrufen 
  Timer1.Interval := 55; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  bm.free; 
end; 
 
procedure TForm1.ausblenden; 
var 
  p: PByteArray; 
  x, y, a, b, c, z, b3: integer; 
begin 
  b3 := bm.width * 3; 
  b := auslaufzone * 3; 
  c := b3 - b; 
  for y := 0 to bm.height - 1 do begin 
    p := bm.scanline[y]; 
    if wo in [abLinks, abBeide] then begin 
      x := 0; 
      while x < b do begin 
        if ((p[x] <> bh) or (p[x + 1] <> gh) or (p[x + 2] <> rh)) 
          then begin 
          a := b - x; 
          p[x] := (p[x] * x + ba * a) div b; 
          p[x + 1] := (p[x + 1] * x + ga * a) div b; 
          p[x + 2] := (p[x + 2] * x + ra * a) div b; 
        end; 
        inc(x, 3); 
      end; 
    end; 
    if wo in [abRechts, abBeide] then begin 
      x := b3; 
      while x >= c do begin 
        if ((p[x] <> bh) or (p[x + 1] <> gh) or (p[x + 2] <> rh)) 
          then begin 
          a := b3 - x; 
          z := x - c; 
          p[x] := (p[x] * a + ba * z) div b; 
          p[x + 1] := (p[x + 1] * a + ga * z) div b; 
          p[x + 2] := (p[x + 2] * a + ra * z) div b; 
        end; 
        dec(x, 3); 
      end; 
    end; 
  end; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  with bm do begin 
    // --- entweder --- 
    canvas.brush.color := hintergrund; 
    canvas.fillrect(canvas.cliprect); 
    // --- oder ------- 
    // canvas.draw(0, 0, aPicture); 
    // ----------------- 
    canvas.brush.style := bsClear; 
    canvas.TextOut(fase, 1, schrift); 
    canvas.TextOut(fase + sbreite, 1, schrift); 
  end; 
  ausblenden; 
  canvas.draw(links, oben, bm); 
  dec(fase, step); 
  if fase <= -sbreite then fase := 0; 
end; 
 
// Beispiel für Änderungen 
 
procedure TForm1.Button4Click(Sender: TObject); 
begin 
  wo := abBeide; 
  breite := 82; // Breite des Laufschriftfeldes 
  schrift := '  + + +  Das ist ein Test für eine ' + 
    'Laufschrift, welche breiter ist als der Wert in der Variablen  "Breite" '; 
  step := 2; 
  auslaufzone := 25; 
  hintergrund := $DA; 
  schriftfarbe := clYellow; 
  ausblendfarbe := clBlack; 
  fontname := 'Times New Roman'; 
  fontstyle := [fsBold]; 
  fontsize := 12; 
  Timer1.Interval := 35; 
  config; // unbedingt immer nach Änderungen aufrufen 
end;