type 
   staerke = 1..7; 
 
procedure Stempel(bm: TBitmap; Untergrund, Farbe: TColor; 
   zufall: boolean; stark: staerke); 
var 
   h, z, r, g, b, r2, g2, b2: byte; 
   x, y, w, bx: integer; 
   p: PBytearray; 
begin 
   if zufall then randomize 
   else randseed := 91735; 
   z := 4; 
   h := succ(z); 
   bm.pixelformat := pf24bit; 
   Untergrund := ColorToRGB(Untergrund); 
   Farbe := ColorToRGB(Farbe); 
   r := getrvalue(Untergrund); 
   g := getgvalue(Untergrund); 
   b := getbvalue(Untergrund); 
   r2 := getrvalue(Farbe); 
   g2 := getgvalue(Farbe); 
   b2 := getbvalue(Farbe); 
   with bm, canvas do 
      for w := 1 to stark do begin 
         pen.color := Untergrund; 
         moveto(random(width), random(height div 2)); 
         lineto(random(width div 2), random(height)); 
      end; 
   r2 := round((r * Z + r2) / h); 
   g2 := round((g * Z + g2) / h); 
   b2 := round((b * Z + b2) / h); 
   bx := bm.width * 3; 
   for w := 1 to stark do 
      for y := 0 to bm.height - 1 do begin 
         p := bm.scanline[y]; 
         x := 0; 
         while x < bx do begin 
            if ((p[x] <> b) or (p[x + 1] <> g) or (p[x + 2] <> r)) 
               and (random(24) = 0) 
               then begin 
               if random(7) > 1 then begin 
                  p[x] := b2; 
                  p[x + 1] := g2; 
                  p[x + 2] := r2; 
               end else begin 
                  p[x] := b; 
                  p[x + 1] := g; 
                  p[x + 2] := r; 
               end; 
            end; 
            inc(x, 3); 
         end; 
      end; 
end; 
 
 
// Beispielaufruf 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
   bmp: TBitmap; 
begin 
   bmp := TBitmap.create; 
   Image1.picture.loadfromfile('stempel.bmp'); 
   bmp.assign(Image1.picture.bitmap); 
   Stempel(bmp, clwhite, clblue, false, 5); 
   canvas.draw(Image1.boundsrect.right + 5, Image1.top, bmp); 
   bmp.free; 
end;