procedure saturation(src: TGraphic; dst: TBitmap; satt: double); 
var 
  x, y, b3, sm, q: integer; 
  p: PBytearray; 
  gr: double; 
  function rech(b: byte): byte; 
  var 
    h: integer; 
  begin 
    h := trunc(gr + satt * (b - gr)); 
    if h < 0 then result := 0 
    else if h > 255 then result := 255 
    else result := h; 
  end; 
begin 
  if not Assigned(src) then exit; 
  satt := abs(satt / 100.0); 
  if satt > 50.0 then satt := 50.0; 
  dst.width := src.width; 
  dst.height := src.height; 
  dst.pixelformat := pf24bit; 
  dst.canvas.draw(0, 0, src); 
  if satt = 1.0 then exit; 
  b3 := dst.width * 3; 
  for y := 0 to dst.height - 1 do begin 
    x := 0; 
    p := dst.scanline[y]; 
    while x < b3 do begin 
      if (p[x] <> p[x + 1]) or (p[x] <> p[x + 2]) then begin 
        sm := p[x] + p[x + 1] + p[x + 2]; 
        if (sm > 0) and (sm < 765) then begin 
          q := p[x] * p[x] + p[x + 1] * p[x + 1] + p[x + 2] * p[x + 2]; 
          gr := sm * $FF / sqrt(195075.0 * q) * sqrt(q); 
          gr := sqrt((gr * gr) / 3); 
          p[x] := rech(p[x]); 
          p[x + 1] := rech(p[x + 1]); 
          p[x + 2] := rech(p[x + 2]); 
        end; 
      end; 
      inc(x, 3); 
    end; 
  end; 
end; 
 
// Beispielaufruf: 
// eine TTrackbar und ein TImage auf die Form setzen, 
// ein Bild ins TImage laden. 
 
var 
  bm: TBitmap; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  bm := TBitmap.create; 
  with Trackbar1 do begin 
    Min := 0; 
    Max := 300; 
    PageSize := 10; 
    Frequency := 10; 
    Position := 100; 
  end; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  bm.free; 
end; 
 
procedure TForm1.TrackBar1Change(Sender: TObject); 
begin 
  with TTrackbar(Sender) do begin 
    label1.caption := inttostr(position); 
    saturation(Image1.picture.graphic, bm, position); 
  end; 
  canvas.draw(Image1.left + Image1.width + 5, Image1.top, bm); 
end; 
 
procedure TForm1.FormPaint(Sender: TObject); 
begin 
  TrackBar1Change(Trackbar1); 
end;