## 2011. március 3., csütörtök

### How to convert a truecolor bitmap to greyscale

Problem/Question/Abstract:

How to convert a truecolor bitmap to greyscale

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;