// Rolltext wie bei STAR WARS Filmen:
// Die Grundidee stammt von Phillip CroColl. Allerdings habe
// ich an der Sache ein wenig herumgedoktort. Der Schriftzug
// verschwindet im Dunklen, Sterne sind zu sehen und ein Logo
// wird dem Text vorangestellt. Dieses Logo wird farblich der
// Schriftfarbe angepasst. Schrift- und Untergrundfarbe sind
// dabei frei wählbar, sollten sich aber deutlich von einander
// unterscheiden.
// HINWEIS: Jede Textzeile muss mit einem Zeilenumbruch (#13)
// versehen sein.

// Getestet mit D2010 unter Win7

Logo

DEMO download

// Achtung!
// Im Demo ist zusätzlich ein Bild integriert. Aus Gründen der
// Übersichtlichkeit wurde das im Code weggelassen.
 

type 
  TForm1 = class(TForm) 
    Image1: TImage; 
    Button1: TButton; 
    procedure FormCreate(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
  private 
    { Private declarations } 
  public 
    { Public declarations } 
    procedure SWRoll(moveY: Integer); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
const 
  txt = 
    'Es war an einem kalten Dezemberabend'#13 + 
    'als ein kleiner, dicker Programmierer'#13 + 
    'unbedingt den Rolltext von STAR WARS'#13 + 
    'programmieren wollte. Damit er nicht'#13 + 
    'das Fahrrad ein zweites Mal erfinden'#13 + 
    'musste, suchte er im Netz nach einem'#13 + 
    'Beispiel. Der Quelltext von Phillip'#13 + 
    'Crocoll aus dem Jahr 1999 wurde somit'#13 + 
    'die Vorlage für das, was gerade vor'#13 + 
    'Ihren Augen abläuft. Allerdings hat der'#13 + 
    'kleine, dicke Programmierer einiges'#13 + 
    'dazu getan.'; 
 
type 
  TripleArray = array [0 .. 0] of TRGBTriple; 
  PTriple = ^TripleArray; 
 
var 
  sz: TSize; 
  m: TRGBTriple; 
  sl: TStringlist; 
  StarBack: TBitmap; 
  Hlp, Source: TBitmap; 
  arroi: array of Integer; 
  mg1, mg2, sw2, mLft: Single; 
  p1, r1, r2, srcCoord: TPoint; 
  DR, DG, DB, sh, Tp, SnZ, StY: Integer; 
 
  FontColor: TColor = clYellow; 
  GroundColor: TColor = clBlack; 
 
procedure TForm1.SWRoll(moveY: Integer); 
var 
  param, startX, stopX: Single; 
  xc, yc: Integer; 
  HlpTP, SrcTP: PTriple; 
begin 
  BitBlt(Hlp.Canvas.Handle, 0, 0, StarBack.Width, StarBack.Height, 
    StarBack.Canvas.Handle, 0, 0, srcCopy); 
  startX := (Hlp.Width - Tp) / 2; 
  stopX := Hlp.Width - startX; 
  for yc := 1 to Hlp.Height - 1 do 
  begin 
    startX := startX + mLft; 
    stopX := stopX - mLft; 
    r2.y := StY - yc; 
    param := (p1.y * r2.x - p1.x * r2.y) / (r1.x * r2.y - r1.y * r2.x); 
    srcCoord.y := Source.Height - Round(Source.Height * param) + moveY; 
    if (srcCoord.y <= 0) or (srcCoord.y >= Source.Height) then 
      continue; 
    SrcTP := Source.ScanLine[srcCoord.y]; 
    HlpTP := Hlp.ScanLine[yc]; 
    for xc := Round(startX) to Round(stopX) do 
    begin 
      srcCoord.x := Round((xc - startX) / (stopX - startX) * Source.Width); 
      if (srcCoord.x > 0) and (srcCoord.x < Source.Width) then 
      begin 
        if (SrcTP[srcCoord.x].rgbtBlue <> m.rgbtBlue) or 
          (SrcTP[srcCoord.x].rgbtGreen <> m.rgbtGreen) or 
          (SrcTP[srcCoord.x].rgbtRed <> m.rgbtRed) then 
        begin 
          HlpTP[xc].rgbtRed := Round(m.rgbtRed + (DR * yc / sh)); 
          HlpTP[xc].rgbtGreen := Round(m.rgbtGreen + (DG * yc / sh)); 
          HlpTP[xc].rgbtBlue := Round(m.rgbtBlue + (DB * yc / sh)); 
        end; 
      end; 
    end; 
  end; 
end; 
 
// maximale Schriftbreite 
function breadth(Cnv: TCanvas): Integer; 
var 
  i: Integer; 
begin 
  setlength(arroi, sl.Count); 
  result := 0; 
  for i := 0 to sl.Count - 1 do 
  begin 
    sz := Cnv.TextExtent(sl[i]); 
    arroi[i] := sz.cx; 
    if sz.cx > result then 
      result := sz.cx; 
  end; 
end; 
 
// Lesbarkeit verbessern 
procedure SetFontAlias(Font: TFont); 
var 
  LogFont: TLogFont; 
begin 
  try 
    if GetObject(Font.Handle, SizeOf(TLogFont), @LogFont) = 0 then 
      exit; 
    LogFont.lfQuality := NONANTIALIASED_QUALITY; 
    Font.Handle := CreateFontIndirect(LogFont); 
  except 
  end; 
end; 
 
// Blocksatz 
procedure justifiedPrint(Cnv: TCanvas; Tp, Wdth: Integer); 
var 
  i, z, b, d, lr, x, w: Integer; 
  p: PChar; 
  s, g: string; 
begin 
  SetFontAlias(Cnv.Font); 
  b := Cnv.Textwidth(#32); 
  for i := 0 to sl.Count - 1 do 
  begin 
    z := 0; 
    p := @sl[i][1]; 
    while p^ <> #0 do 
    begin 
      if p^ = #32 then 
        inc(z); 
      inc(p); 
    end; 
    if ((z < 2) // weniger als 3 Worte pro Zeile 
      and (arroi[i] < Wdth * 0.9)) or (z = 0) then 
      Cnv.textout((Wdth - arroi[i]) div 2, i * sz.cy + Tp, sl[i]) 
    else 
    begin 
      g := sl[i]; 
      w := 0; 
      d := Trunc((Wdth - arroi[i] + z * b) / z); 
      for x := 0 to z - 1 do 
      begin 
        lr := pos(#32, g); 
        s := copy(g, 1, lr - 1); 
        Cnv.textout(w, i * sz.cy + Tp, s); 
        inc(w, d + Cnv.Textwidth(s)); 
        delete(g, 1, lr); 
      end; 
      Cnv.textout(w, i * sz.cy + Tp, g); 
    end; 
  end; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  i, x, y: Integer; 
  b, RCF, GCF, BCF: byte; 
begin 
  DoubleBuffered := true; 
  Hlp := TBitmap.Create; 
  Hlp.LoadFromFile('DELPHI.bmp'); // Logo 
  // Hlp.Handle := loadbitmap(hinstance, 'DELPHI'); 
  Hlp.TransparentColor := clBlack; 
  Hlp.Transparent := true; 
  Source := TBitmap.Create; 
  Source.PixelFormat := pf24bit; 
  sl := TStringlist.Create; 
  sl.Text := txt; 
  with Source do 
  begin 
    Canvas.brush.color := GroundColor; 
    Canvas.Font.color := FontColor; 
    Canvas.Font.Name := 'Arial'; 
    Canvas.Font.Size := 17; 
    Canvas.Font.Style := [fsBold]; 
    Width := breadth(Canvas); 
    Height := sz.cy * sl.Count + Hlp.Height; 
    Canvas.Draw((Width - Hlp.Width) div 2, 0, Hlp); // Logo 
    justifiedPrint(Canvas, Hlp.Height, Width); 
  end; 
  sh := Source.Height div 2 + 50; // kann beliebig variieren 
  inc(sh, ord(odd(sh))); 
  with Image1 do 
  begin 
    AutoSize := true; 
    with Picture.Bitmap, Canvas do 
    begin 
      brush.color := GroundColor; 
      Width := Source.Width; 
      Height := sh; 
    end; 
  end; 
  GroundColor := ColorToRGB(GroundColor); 
  FontColor := ColorToRGB(FontColor); 
  m.rgbtRed := GetRValue(GroundColor); 
  m.rgbtGreen := GetGValue(GroundColor); 
  m.rgbtBlue := GetBValue(GroundColor); 
 
  // --- einfacher Sternenhimmel --- 
  StarBack := TBitmap.Create; 
  StarBack.Canvas.brush.color := GroundColor; 
  StarBack.Width := Source.Width; 
  StarBack.Height := sh; 
  for i := 0 to Trunc(sqrt(StarBack.Height * sh)) do 
  begin 
    b := Random(2) * $FF; 
    with StarBack.Canvas do 
    begin 
      x := Random(StarBack.Width); 
      y := Random(StarBack.Height); 
      SetPixel(Handle, x, y, RGB(255, 255, b)); 
    end; 
  end; 
  Image1.Canvas.Draw(0, 0, StarBack); 
  // ------------------------------- 
 
  Hlp.Transparent := false; 
  Hlp.Width := Source.Width; 
  Hlp.Height := sh; 
  Hlp.PixelFormat := Source.PixelFormat; 
  sw2 := Source.Width / 2; 
  mg1 := 1 / (sw2 + Source.Height); 
  mg2 := 1 / sw2; 
  SnZ := Round(Hlp.Height / (mg1 - mg2)); 
  StY := Round(mg1 * SnZ); 
  Tp := Round(Hlp.Width * Source.Width / (sw2 + Source.Height) / 2); 
  p1.x := Source.Width div 2; 
  p1.y := 1; 
  r1.x := Source.Height; 
  r1.y := 0; 
  r2.x := SnZ; 
  mLft := (Tp - Hlp.Width) / 2 / Hlp.Height; 
  RCF := GetRValue(FontColor); 
  GCF := GetGValue(FontColor); 
  BCF := GetBValue(FontColor); 
  DR := RCF - m.rgbtRed; 
  DG := GCF - m.rgbtGreen; 
  DB := BCF - m.rgbtBlue; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  arroi := nil; 
  StarBack.Free; 
  Source.Free; 
  Hlp.Free; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  i: Integer; 
  tense: Cardinal; 
begin 
  Button1.Enabled := false; 
  for i := -Source.Height to Source.Height do 
  begin 
    SWRoll(i); 
    with Image1.Canvas do 
      Draw(0, 0, Hlp); 
    tense := Gettickcount + 55; 
    repeat 
      Application.ProcessMessages; 
      if Application.Terminated then 
        exit; 
    until Gettickcount >= tense; 
  end; 
  Button1.Enabled := true; 
end;