How to convert a truecolor bitmap to greyscale (Views: 29)
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; |