procedure angleichen(Bild: TBitmap; Grundfarbe: TColor; Prozent: Single); 
var 
  x, y, b3: integer; 
  p: PBytearray; 
  r, g, b: Byte; 
begin 
  if (Prozent = 0) or (Bild.width = 0) or (Bild.height = 0) then exit; 
  if Prozent > 100 then Prozent := 100; 
  bild.pixelformat := pf24bit; 
  Grundfarbe := ColorToRGB(Grundfarbe); 
  r := getrvalue(Grundfarbe); 
  g := getgvalue(Grundfarbe); 
  b := getbvalue(Grundfarbe); 
  b3 := bild.width * 3; 
  for y := 0 to bild.height - 1 do begin 
    p := bild.scanline[y]; 
    x := 0; 
    while x < b3 do begin 
      if (abs(b - p[x]) * 100 / 255 <= Prozent) 
        and (abs(g - p[x + 1]) * 100 / 255 <= Prozent) 
        and (abs(r - p[x + 2]) * 100 / 255 <= Prozent) 
        then begin 
        p[x] := b; 
        p[x + 1] := g; 
        p[x + 2] := r; 
      end; 
      inc(x, 3); 
    end; 
  end; 
end; 
 
 
// Beispielaufruf 
 
procedure TForm1.Button9Click(Sender: TObject); 
begin 
  angleichen(Image1.picture.bitmap, clWhite, 25); 
  image1.refresh; 
end;