procedure grbest(bm: TBitmap); 
var 
  x, y, z, b3: Integer; 
  p: PBytearray; 
  mi, ma: array[0..2] of byte; 
  faktor: array[0..2] of double; 
begin 
  bm.pixelformat := pf24bit; 
  b3 := bm.width * 3; 
  for x := 0 to 2 do begin 
    mi[x] := $FF; 
    ma[x] := 0; 
  end; 
  for y := 0 to bm.height - 1 do begin 
    p := bm.scanline[y]; 
    x := 0; 
    while x < b3 do begin 
      for z := 0 to 2 do begin 
        if p[x + z] < mi[z] then mi[z] := p[x + z]; 
        if p[x + z] > ma[z] then ma[z] := p[x + z]; 
      end; 
      inc(x, 3); 
    end; 
  end; 
  for x := 0 to 2 do 
    faktor[x] := 255 / (ma[x] - mi[x]); 
  for y := 0 to bm.height - 1 do begin 
    p := bm.scanline[y]; 
    x := 0; 
    while x < b3 do begin 
      for z := 0 to 2 do 
        p[x + z] := trunc((p[x + z] - mi[z]) * faktor[z]); 
      inc(x, 3); 
    end; 
  end; 
end; 
 
// Beispielaufruf 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  grbest(image1.picture.bitmap); 
  grbest(image2.picture.bitmap); 
  grbest(image3.picture.bitmap); 
  image1.refresh; 
  image2.refresh; 
  image3.refresh; 
end;