type 
  PColor = ^TColor; 
 
procedure trans(bm, grund: TBitmap; Farbe: PColor; oben: boolean); 
var 
  r, g, b, d, c: byte; 
  x, y, w, h: integer; 
  p, pu: PBytearray; 
  f: double; 
begin 
  bm.pixelformat := pf24bit; 
  grund.pixelformat := pf24bit; 
  w := bm.width * 3; 
  h := bm.height - 1; 
  if Farbe <> nil then begin 
    Farbe^ := ColorToRGB(Farbe^); 
    r := getrvalue(Farbe^); 
    g := getgvalue(Farbe^); 
    b := getbvalue(Farbe^); 
  end; 
  f := 255 / h; 
  for y := 0 to h do begin 
    p := bm.scanline[y]; 
    pu := grund.scanline[y]; 
    c := trunc(f * y); 
    d := trunc(255 - f * y); 
    if oben then begin 
      x := c; 
      c := d; 
      d := x; 
    end; 
    x := 0; 
    while x < w do begin 
      if (Farbe = nil) or (p[x] = b) and (p[x + 1] = g) and (p[x + 2] = r) 
        then begin 
        p[x] := (p[x] * d + pu[x] * c) shr 8; 
        p[x + 1] := (p[x + 1] * d + pu[x + 1] * c) shr 8; 
        p[x + 2] := (p[x + 2] * d + pu[x + 2] * c) shr 8; 
      end; 
      inc(x, 3); 
    end; 
  end; 
end; 
 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  b: TBitmap; 
  c: TColor; 
begin 
  c := clWhite; 
  b := TBitmap.create; 
  Image1.autosize := true; 
  Image1.picture.loadfromfile('c:\test.bmp'); 
  b.width := Image1.width; 
  b.height := Image1.height; 
  Image1.visible := false; 
  application.processmessages; 
  b.canvas.copyrect(b.canvas.cliprect, Canvas, Image1.boundsrect); 
 
  trans(Image1.picture.bitmap, b, @c, false);
//trans(Image1.picture.bitmap, b, nil, false); 
 
  b.free; 
  Image1.visible := true; 
end;