procedure TexturSchrift(c: TCanvas; x, y, fontsize: integer; 
  txt, fontname: string; bitmap: TBitmap; hintergrund: TColor; 
  transparenz: boolean); 
var 
  rgn: HRGN; 
  bmp: TBitmap; 
  i, j: integer; 
begin 
  bmp := TBitmap.Create; 
  BeginPath(c.handle); 
  SetBkMode(c.handle, TRANSPARENT); 
  c.font.name := fontname; 
  c.font.size := fontsize; 
  c.font.style := [fsbold]; 
  bmp.width := c.textwidth(txt); 
  bmp.height := c.textheight(txt); 
  bmp.canvas.brush.color := hintergrund; 
  bmp.canvas.fillrect(bmp.canvas.cliprect);
  TextOut(c.handle, 0, 0, pchar(txt), length(txt)); 
  EndPath(c.handle); 
  rgn := PathToRegion(c.handle); 
  SelectClipRgn(bmp.canvas.handle, rgn); 
  for i := 0 to bmp.width div bitmap.width do 
    for j := 0 to bmp.height div bitmap.height do 
      bmp.canvas.draw(i * bitmap.width, j * bitmap.height, bitmap); 
  SelectClipRgn(bmp.canvas.handle, 0); 
  bmp.transparent := transparenz; 
  c.Draw(x, y, bmp); 
  DeleteObject(rgn); 
  bmp.Free; 
end; 
 
 
// Beispielaufruf 
var 
  b: TBitmap; 
const 
  transp: boolean = true; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  b := TBitmap.create; 
  b.loadfromfile('d:\texturen\flower.bmp'); 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  b.free; 
end; 
 
procedure TForm1.FormPaint(Sender: TObject); 
begin 
  texturschrift(canvas, 75, 150, 60, 'Das ist ein Test', 'Arial', 
    b, clblue, transp); 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  transp := not transp; 
  repaint; 
end;