type 
  kind = (aLeftFront, aLeftBack, aRightFront, aRightBack); 
  location = (jLeft, jCenter, jRight); 
  PColor = ^TColor; 
 
var 
  bilder: array of TBitmap = nil; 
 
function wx(const w, b, m: integer): integer; 
begin 
  result := round(cos((pi / 180) * w - pi / 2) * (b / 2)) + m; 
end; 
 
procedure matrix(z: word = 0; Fontname: TFontname = ''; 
  Fontstyle: TFontstyles = []; Fontsize: integer = 0; 
  Fontcolor: TColor = 0; Hintergrund: TColor = 0); 
var 
  x: integer; 
begin 
  for x := 0 to high(bilder) do 
    bilder[x].Free; 
  setlength(bilder, z); 
  if z > 0 then 
    for x := 0 to high(bilder) do begin 
      bilder[x] := TBitmap.Create; 
      with bilder[x], Canvas do begin 
        Font.Name := Fontname; 
        Font.style := Fontstyle; 
        Font.Size := Fontsize; 
        Font.Color := Fontcolor; 
        Brush.Color := Hintergrund; 
        Fillrect(cliprect); 
      end; 
    end; 
end; 
 
function klappen(bm: TBitmap; Ziel: TCanvas; x, y, winkel: integer; av: kind; 
  wo: location; Rahmen: PColor): integer; 
var 
  mx, i, lk, dff, v, o, br, xx, yo, yu: integer; 
  s, hv, h, st, a, k: single; 
begin 
  if Rahmen <> nil then 
    ziel.Pen.color := Rahmen^; 
  with bm do begin 
    mx := x + round(width / 2); 
    br := x + width; 
    lk := wx((270 - winkel * 2), width, mx); 
    dff := br - lk; 
    if dff = 0 then st := 0 else 
      st := width / dff; 
    hv := (height * winkel) / 90; 
    case av of 
      aRightFront: begin 
          v := 1; 
          h := 0; 
        end; 
      aRightBack: begin 
          v := -1; 
          h := 0; 
        end; 
      aLeftFront: begin 
          v := -1; 
          h := hv / 4; 
        end; 
    else begin 
        v := 1; 
        h := -hv / 4; 
      end; 
    end; 
    case wo of 
      jRight: o := lk - x; 
      jLeft: o := 0; 
    else o := (lk - x) div 2; 
    end; 
    Result := br - lk + x; 
    a := 0; 
    s := 0; 
    if dff = 0 then k := 0 else 
      k := hv * v / (dff * 4); 
    for i := lk to br do begin 
      xx := o + i - lk + x; 
      yo := round(y - a - h); 
      yu := round(y + height + a + h); 
      if (Rahmen <> nil) and ((i = lk) or (i = br)) then begin 
        ziel.moveto(xx, yo); 
        ziel.lineto(xx, yu); 
      end else begin 
        ziel.CopyRect(rect(xx, yo, xx + 1, yu), 
          canvas, rect(round(s), 0, round(s + 1), height)); 
        if Rahmen <> nil then begin 
          setpixel(ziel.Handle, xx, yo, Rahmen^); 
          setpixel(ziel.Handle, xx, yu, Rahmen^); 
        end; 
      end; 
      a := a + k; 
      s := s + st; 
    end; 
  end; 
end; 
 
function zeige(ziel: TCanvas; welch, x, y, abstand: integer; 
  Grad: byte; av: kind; st: location; Rahmen: PColor): integer; 
begin 
  while Grad > 90 do dec(grad, 90); 
  Result := klappen(bilder[welch], ziel, x, y, Grad, av, st, Rahmen) 
    + abstand; 
end; 
 
procedure build(txt: string; Fontname: TFontname; Fontstyle: TFontStyles; 
  Fontsize, Rand: integer; Fontcolor, Hintergrund: TColor; Rahmen: PColor); 
var 
  lg, x, z, w, g: integer; 
  sz: TSize; 
begin 
  lg := length(txt); 
  matrix(lg, Fontname, Fontstyle, Fontsize, Fontcolor, Hintergrund); 
  g := 0; 
  for x := 0 to pred(lg) do 
    with bilder[x].canvas do begin 
      w := textwidth(txt[succ(x)]); 
      if w > g then g := w; 
    end; 
  for x := 0 to pred(lg) do 
    with bilder[x], canvas do begin 
      z := ord(Rahmen <> nil); 
      sz := textextent(txt[succ(x)]); 
      width := g + 2 * (rand + z); 
      height := sz.cy; 
      textout((width - sz.cx) div 2, 0, txt[succ(x)]); 
    end; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  matrix; 
end; 
 

// ====================== Beispiele ====================
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  i, x, y, Rand, Winkel, Fontsize, Abstand: integer; 
begin 
  Fontsize := 35; 
  Rand := 10; 
  build('VERSUCH', 'Courier New', 
    [fsbold], Fontsize, Rand, clBlack, clAqua, nil); 
  Abstand := 5; 
  Winkel := 35; 
  x := 15; 
  y := 20; 
  for i := 0 to high(bilder) do 
    x := zeige(canvas, i, x, y, Abstand, Winkel, aLeftFront, jLeft, nil); 
end; 

 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  i, x, y, Rand, Winkel, Fontsize, Abstand: integer; 
begin 
  Fontsize := 40; 
  Rand := 10; 
  build('DELPHI', 'Courier New', 
    [fsbold], Fontsize, Rand, clRed, clBtnFace, nil); 
  Abstand := 0; 
  Winkel := 45; 
  x := 15; 
  y := 120; 
  for i := 0 to high(bilder) do 
    x := zeige(canvas, i, x, y, Abstand, Winkel, aRightFront, jLeft, nil); 
end; 

 
var 
  arr: array[0..4] of integer = (0, 30, 57, 82, 104); 
 
procedure TForm1.Button3Click(Sender: TObject); 
var 
  i, x, y, h, Rand, Winkel, Fontsize, Abstand: integer; 
  Rahmen: PColor; 
  Rahmenfarbe: TColor; 
begin 
  Rahmenfarbe := clNavy; 
  Rahmen := @Rahmenfarbe; 
  Fontsize := 40; 
  Rand := 10; 
  build('MELBOURNE', 'Courier New', 
    [fsbold], Fontsize, Rand, clNavy, clWhite, Rahmen); 
  h := high(bilder); 
  Abstand := -8; 
  Winkel := 30; 
  x := 15; 
  y := 230; 
  for i := 0 to 3 do 
    x := zeige(canvas, i, x, y, Abstand, Winkel + i * 4, 
      aLeftFront, jLeft, Rahmen); 
  x := 255; 
  for i := 0 to 4 do 
    zeige(canvas, h - i, x - arr[i], y, Abstand, 
      Winkel + succ(i) * 4, aRightFront, jLeft, Rahmen); 
end;