How to convert a truecolor bitmap to greyscale

Problem/Question/Abstract:

How to convert a truecolor bitmap to greyscale

Answer:

Solve 1:

Here's a greyscale routine that uses a 24-bit bitmap and scanline. It also has integer math to help speed it up:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, jpeg, ExtCtrls;

type
  TRGBArray = array[0..32767] of TRGBTriple;
  pRGBArray = ^TRGBArray;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure GrayScale(b: TBitmap);
var
  i, j, Colr: Integer;
  sl: pRGBArray; {Scanline}
begin
  if b.PixelFormat <> pf24bit then
  begin
    ShowMessage('not a truecolor bmp');
    Exit;
  end;
  for j := 0 to b.Height - 1 do
  begin
    sl := b.ScanLine[j];
    for i := 0 to b.Width - 1 do
    begin
      Colr := HiByte(sl[i].rgbtRed * 77 + sl[i].rgbtGreen * 151 + sl[i].rgbtBlue * 28);
      sl[i].rgbtRed := Colr;
      sl[i].rgbtGreen := Colr;
      sl[i].rgbtBlue := Colr;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  bmp: TBitmap;
begin
  bmp := TBitmap.Create;
  bmp.PixelFormat := pf24bit;
  bmp.Width := Image1.Picture.Graphic.Width;
  bmp.Height := Image1.Picture.Graphic.Height;
  bmp.Canvas.Draw(0, 0, Image1.Picture.Graphic);
  GrayScale(bmp);
  Image1.Picture.Assign(bmp);
  bmp.Free;
end;

end.


Solve 2:

function CreateGreyScaleBmp(Source: TBitmap): TBitmap;
var
  Table: array[Byte] of TRGBQuad;
  I: Integer;
begin
  Result := TBitmap.Create;
  with Result do
  begin
    PixelFormat := pf8Bit;
    Width := Source.Width;
    Height := Source.Height;
    for I := Low(Table) to High(Table) do
      with Table[I] do
      begin
        rgbRed := I;
        rgbGreen := I;
        rgbBlue := I;
        rgbReserved := 0;
      end;
    if SetDIBColorTable(Canvas.Handle, Low(Table), High(Table), Table) = 0 then
      RaiseLastWin32Error;
    Canvas.Draw(0, 0, Source);
  end;
end;


Solve 3:

procedure ConvertBitmapToGrayscale(const Bitmap: TBitmap);
type
  PPixelRec = ^TPixelRec;
  TPixelRec = packed record
    B: Byte;
    G: Byte;
    R: Byte;
    Reserved: Byte;
  end;
var
  X: Integer;
  Y: Integer;
  P: PPixelRec;
  Gray: Byte;
begin
  Assert(Bitmap.PixelFormat = pf32Bit);
  for Y := 0 to (Bitmap.Height - 1) do
  begin
    P := Bitmap.ScanLine[Y];
    for X := 0 to (Bitmap.Width - 1) do
    begin
      {Standard equation}
      Gray := Round(0.30 * P.R + 0.59 * P.G + 0.11 * P.B);
      {33% faster but slightly less accurate equation}
      // Gray := (P.R shr 2) + (P.R shr 4) + (P.G shr 1) + (P.G shr 4) + (P.B shr 3);
      P.R := Gray;
      P.G := Gray;
      P.B := Gray;
      Inc(P);
    end;
  end;
end;

If you just want to remove the red and green components, or the green and blue components, or the red and blue components, then you can modify this procedure by commenting out one or more of the P.* := Gray lines in the for-loop. Or you could force some color components to 0 or $FF. The procedure as written will only work for 32-bit bitmaps, but it can easily be adjusted to 24-bit bitmaps by removing the Reserved member of the TPixelRec record type, and adjusting the Assert() call.


Solve 4:

{ ... }
type
  TRGBArray = array[Word] of TRGBTriple;
  pRGBArray = ^TRGBArray;

procedure GrayScale(Src: TBitmap);
var
  Lum, x, y: integer;
  SrcLine: pRGBArray;
  SrcGap: integer;
begin
  Src.PixelFormat := pf24bit;
  SrcLine := Src.ScanLine[0];
  SrcGap := Integer(Src.ScanLine[1]) - Integer(SrcLine);
  for y := 0 to pred(Src.Height) do
  begin
    for x := 0 to pred(Src.Width) do
    begin
      Lum := Round(SrcLine[x].rgbtRed * 0.3 + SrcLine[x].rgbtGreen * 0.59 +
        SrcLine[x].rgbtBlue * 0.11);
      SrcLine[x].rgbtRed := Lum;
      SrcLine[x].rgbtGreen := Lum;
      SrcLine[x].rgbtBlue := Lum;
    end;
    SrcLine := pRGBArray(Integer(SrcLine) + SrcGap);
  end;
end;


Solve 5:

uses
  Math;

procedure GrayImage(Image: TBitmap);
var
  X, Y: Integer;
  RGBCol: COLORREF;
begin
  for Y := 0 to Image.Height do
    for X := 0 to Image.Width do
    begin
      if Image.Canvas.Pixels[X, Y] <> clNone then
      begin
        RGBCol := ColorToRGB(Image.Canvas.Pixels[X, Y]);
        RGBCol := (Trunc(Math.Mean([GetRValue(RGBCol), GetGValue(RGBCol),
          GetBValue(RGBCol)])) + 192) div 2;
        Image.Canvas.Pixels[X, Y] := RGB(RGBCol, RGBCol, RGBCol);
      end;
    end;
end;


Solve 6:

procedure GrayscaleRect(Graphic: TBitmap; R: TRect);
var
  I, J: Integer;
  BitsTo: PRGBTripleArray;
  Gray: Byte;
begin
  Graphic.PixelFormat := pf24bit;
  for J := R.Top to R.Bottom - 1 do
  begin
    BitsTo := Graphic.ScanLine[J];
    for I := R.Left to R.Right - 1 do
    begin
      with BitsTo[I] do
      begin
        gray := (BitsTo[I].rgbtBlue + BitsTo[I].rgbtGreen + BitsTo[I].rgbtRed) div 3;
        rgbtBlue := Gray;
        rgbtGreen := Gray;
        rgbtRed := Gray;
      end;
    end;
  end;
end;