Bild in Graustufen umwandeln

[Burning_Chrome]

Hi!

In der Delphi-Source.de steht vom Autor Robert Schiebel folgender code (hab ihn schon mal getestet und er funzt super):

Delphi-Quellcode:

type
  TPixelBMP24 = packed record
    R: byte;
    G: byte;
    B: byte;
end;

var
  SrcBMP, DstBMP24: TBitmap;

procedure TForm1.FormCreate(sender: TObject);
begin
  SrcBMP:=TBitmap.Create;  {Src Bitmap erstellen}
  SrcBMP.LoadFromFile('datei'); //sollte 24Bit sein

  DstBMP24:=TBitmap.Create;  {24-Bit Dst Bitmap erstellen}
  DstBMP24.PixelFormat:=pf24bit;
  DstBMP24.Width:=SrcBmp.Width;
  DstBMP24.Height:=SrcBmp.Height;
end;

function BMPRGBtoYUV(rgb: TPixelBMP24): TPixelBMP24;
var y,u,v:longint;
begin
  y := rgb.G*150 + rgb.B*29 + rgb.R*77; // 0.587 x 256, 0.114 x 256, 0.299 x 256
  u := (rgb.B shl 8 - y) * 144;         // 0.564 x 256
  v := (rgb.R shl 8 - y) * 183;         // 0,713 x 256
  Result.G :=y shr 8;
  Result.B :=u shr 16 + $80;
  Result.R :=v shr 16 + $80;
end;

function BMPYUVtoRGB(yuv: TPixelBMP24): TPixelBMP24;
var temp: integer;
begin
  temp := yuv.G + (yuv.B - $80) * 256 div 144  ;
  if temp > 0 then Result.B:=temp else Result.B:=0;
  if temp > 255 then Result.B:=255;

  temp := yuv.G + (yuv.R - $80) * 256 div 183  ;
  if temp > 0 then Result.R:=temp else Result.R:=0;
  if temp > 255 then Result.R:=255;

  temp := (yuv.G shl 8 - Result.B*29 - Result.R*77) div 150;
  if temp > 0 then Result.G:=temp else Result.G:=0;
  if temp > 255 then Result.G:=255;
end;

procedure TForm1.Button4Click(Sender: TObject);
var x, y: integer;
  SrcPixel: ^TPixelBMP24;
  DstPixel: ^TPixelBMP24;
  yuv: TPixelBMP24;
begin
  for y:=0 to SrcBMP.Height-1 do   // SrcBMP und DstBMP24 sind gleich groß !!!
  begin
    SrcPixel:=SrcBMP.ScanLine[y];
    DstPixel:=DstBMP24.ScanLine[y];
    for x:=0 to SrcBMP.Width-1 do
    begin
      yuv:=BMPRGBtoYUV(SrcPixel^);
      yuv.R:=$80;
      yuv.B:=$80;
      DstPixel^ := BMPYUVtoRGB(yuv);
      inc(SrcPixel);
      inc(DstPixel);
    end;
  end;

  Image1.Picture.Graphic:=DstBMP24;
end;

Best_Regards
Burning_Chrome