var 
  stopp: boolean; 
  Txt: string = 'Das ist der erste Versuch  ***  '; 
 
procedure DrehText(cnv: TCanvas; x, y, LWidth, LHeight: integer; leer: boolean); 
var 
  lgth, i, xpos, ypos, oben: integer; 
  zeit: cardinal; 
  s, w: single; 
  bc: TColor; 
  r: TRect; 
  procedure weg; 
  begin 
    cnv.brush.color := bc; 
    cnv.fillrect(r); 
  end; 
begin 
  bc := cnv.brush.color; 
  cnv.Font.name := 'Arial'; // am Besten 
  lgth := length(Txt); 
  xpos := LWidth + x; 
  ypos := LHeight + y; 
  w := 2 * PI / lgth; 
  r := rect(xpos - LWidth, ypos - LHeight, xpos + 
    LWidth * 2, ypos + LHeight * 3); // grobe Schätzung 
  repeat 
    weg; 
    cnv.brush.style := bsClear; 
    for i := 1 to lgth do begin 
      oben := round(ypos - LHeight * sin(i * w)); 
      s := (oben - ypos) * 35 / LHeight; 
      if (s < 9) then s := 9; 
      cnv.font.Size := trunc(s / 1.8); 
      cnv.textout(round(xpos + LWidth * cos(i * w)), oben, Txt[i]); 
    end; 
    zeit := gettickcount + 142; 
    repeat 
      application.processmessages; 
      if application.terminated or stopp then break; 
    until (gettickcount > zeit); 
    Txt := copy(Txt, 2, maxint) + Txt[1]; 
    application.processmessages; 
  until application.terminated or stopp; 
  if stopp and leer then weg; 
end;

 
// Beispielaufrufe 
 
// Start 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  stopp := false; 
  Canvas.brush.color := Color; 
  Canvas.Font.color := clMaroon; 
  DrehText(Canvas, 10, 10, 85, 30, false); 
end; 
 
// Stop 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  stopp := true; 
end;