type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    Timer1: TTimer; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure Timer1Timer(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    { Public-Deklarationen } 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
var 
  schrift, spiegel: TBitmap; 
  x, y, step: integer; 
 
procedure build(txt, Fontname: string; Fontcolor, Spiegelcolor, Background: TColor; 
  Fontsize: integer); 
const 
  vergl = 'pqgyj'; 
var 
  tm: TTextMetric; 
  offs1, offs2, i: integer; 
  b: boolean; 
begin 
  b := false; 
  for i := 1 to length(txt) do 
    if pos(txt[i], vergl) > 0 then begin 
      b := true; 
      break; 
    end; 
  with schrift, canvas do begin 
    brush.color := background; 
    font.name := Fontname; 
    font.color := Fontcolor; 
    font.size := Fontsize; 
    font.style := [fsBold]; 
    SelectObject(handle, Font.handle); 
    GetTextMetrics(handle, tm); 
    if b then begin 
      offs1 := tm.tmInternalLeading - 1; 
      offs2 := 0; 
    end else begin 
      offs2 := tm.tmInternalLeading; 
      offs1 := -1; 
    end; 
    height := tm.tmheight - tm.tmExternalLeading + offs1; 
    width := textwidth(txt); 
    fillrect(cliprect); 
    textout(0, offs2, txt); 
  end; 
  with spiegel, canvas do begin 
    brush.color := background; 
    font.name := Fontname; 
    font.color := Spiegelcolor; 
    font.size := Fontsize; 
    font.style := [fsBold]; 
    height := schrift.height; 
    width := schrift.width; 
    fillrect(cliprect); 
    textout(0, offs2, txt); 
  end; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Timer1.interval := 0; 
  schrift := TBitmap.create; 
  spiegel := TBitmap.create; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  spiegel.free; 
  schrift.free; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  canvas.copyrect(rect(x, y - step, x + schrift.width, y), schrift.canvas, 
    rect(0, 0, schrift.width, step)); 
  canvas.copyrect(rect(x, y + step - 1, x + spiegel.width, y - 1), spiegel.canvas, 
    rect(0, 0, spiegel.width, step)); 
  inc(step); 
  if step = schrift.height then Timer1.interval := 0; 
end; 
 


// Beispielaufruf 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  refresh; // für Wiederholung 
  build('Test', 'Times New Roman', clBlue, $FFB0B0, color, 22); 
  step := 1; 
  x := 30; 
  y := 20 + schrift.height; 
  Timer1.interval := 55; 
end;