Graying Bitmaps and Graphics

Problem/Question/Abstract:

This article shows how to gray a color bitmap. It reduces true-color bitmaps to 256 shades of gray paletted bitmaps, which reduces memory requirements.
The article also provides a function for graying any TGraphic descendant which is assignable to a TBitmap (or who knows how to assign itself to one: AssignTo method)

Answer:

After a while without posting I've came up with this article which explores a simple yet (non)colorful subject: changing color images to gray scale.

Writting a function to do that is easy: one could simply get a bitmap, promote it to 32 or 24 bit true-color, and then get the pixel components, one by one, and change them to the arithmetic avarage (red+green+blue component div 3) for every pixel. Something like:

Bitmap.PixelFormat := pf24Bit;
for y := 0 to Bitmap.Height - 1 do
  for x := 0 to Bitmap.Width div 3 do
  begin
    C := PChar(ScanLine[y])[x * 3] + PChar(ScanLine[y])[x * 3 + 1] +
      PChar(ScanLine[y])[x * 3 + 2] div 3;
    FillChar(PChar(SCanLine[y])[x * 3], 3, C);
  end;

And you will get a grayed bitmap wich is stored as a 24 bit depth true-color picture. What a wast of space and memory... (Attention: I didn't tested the above code, it is much more an algorithm than an implementation... I've written it directly here while writting the article :-)

But using this technique is not a good approach! First, every grayscale image can only have 256 shades of gray in current Windows based computers, since the Red, Green and Blue component each can only vary from 0 to 255. A gray scale image is one where R=G=B, so there can only be 256 possible levels of gray (or intensity). So using true color images to store a gray one is waste of space.

The code bellow in an excerpt from my work on progress DGL (Delphi Graphics Library), which I think I will never finish due to my load on work and at home (I am a Jiu-Jitsu fighter and have to attend to the trainning every day!!!! :-). This code was encapsulated in one filter class (TGrayFilter), because the DGL uses filters to apply effects and transformations on images. Here I've stripped the object orientation completely and wrote two simple functions to do it for you.

It is supposed that you have some familiarity with Bitmap scanlines to fully understand what is going on, and with the methods I use here to manipulate Scanlines. If you didn't have that knowledge, you could take a look at my article "BitmapToRegion (Delphi-like version - very fast) (UPDATE: Bug fix!)", Article # 944. There I enter in more detail about Scanlines and the methods I will use here.


The project bellow is very simple. To test it all you need to do is to save the DFM (which I suplly in text format) by copying and pasting in Notepad and saving the file as Unit1.dfm. After that open the form in Delphi and copy and past the code bellow in the entire unit. After that add this unit to a project and run it.

---- CODE -----

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, JPEG,
  ExtDlgs, StdCtrls, Buttons, ExtCtrls;

type
  TForm1 = class(TForm)
    Image1: TImage;
    btnOpen: TBitBtn;
    OpenPic: TOpenPictureDialog;
    btnGrayBitmap: TBitBtn;
    btnGrayGraphic: TBitBtn;
    procedure btnOpenClick(Sender: TObject);
    procedure btnGrayBitmapClick(Sender: TObject);
    procedure btnGrayGraphicClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{ general routines - They are in a separate unit in my on progress Delphi
  Graphics Library, but for this example I will put them here }

procedure GetScanLineProperties(Bitmap: TBitmap; var Start: Pointer;
  var Dif: Integer);
begin
  Start := Bitmap.ScanLine[0];
  if Bitmap.Height > 1 then
    Dif := Integer(Bitmap.ScanLine[1]) - Integer(Start)
  else
    Dif := 0;
end;

function BuildGrayPalette(PixelFormat: TPixelFormat): HPalette;
var
  Pal: TMaxLogPalette;
  i, step: Integer;
  C: Integer;
begin
  Pal.palVersion := $300;
  step := 1;
  case PixelFormat of
    pf1bit: step := 255;
    pf4bit: step := 16;
    pf8bit: step := 1;
  end;
  if step < 255 then
    Pal.palNumEntries := 256 div step
  else
    Pal.palNumEntries := 2;
  if PixelFormat = pf4bit then
  begin
    C := step - 1;
    for i := 0 to Pal.palNumEntries - 1 do
    begin
      FillChar(Pal.palPalEntry[i], 3, C);
      Pal.palPalEntry[i].peFlags := 0;
      Inc(C, step);
    end;
  end
  else
  begin
    C := 0;
    for i := 0 to Pal.palNumEntries - 1 do
    begin
      FillChar(Pal.palPalEntry[i], 3, C);
      Pal.palPalEntry[i].peFlags := 0;
      Inc(C, step);
    end;
  end;
  Result := CreatePalette(PLogPalette(@Pal)^);
end;

function GrayPaletteEntries(Pal: HPALETTE): HPALETTE;
var
  PaletteSize: Cardinal;
  LogPal: TMaxLogPalette;
  i: Integer;
begin
  Result := 0;
  if Pal = 0 then
    Exit;
  PaletteSize := 0;
  if GetObject(Pal, SizeOf(PaletteSize), @PaletteSize) = 0 then
    Exit;
  if PaletteSize = 0 then
    Exit;
  with LogPal do
  begin
    palVersion := $0300;
    palNumEntries := PaletteSize;
    GetPaletteEntries(Pal, 0, PaletteSize, palPalEntry);
    for i := 0 to palNumEntries - 1 do
      FillChar(palPalEntry[i], 3, (palPalEntry[i].peRed +
        palPalEntry[i].peGreen +
        palPalEntry[i].peBlue) div 3);
  end;
  Result := CreatePalette(PLogPalette(@LogPal)^);
end;

procedure GrayBitmap(Bitmap: TBitmap);
var
  Dest: TBitmap;
  SrcRow, DstRow: PByteArray;
  DstDif, SrcDif, x, y, bpp: Integer;
begin
  GetScanLineProperties(Bitmap, Pointer(SrcRow), SrcDif);
  case Bitmap.PixelFormat of
    { palette - need only to gray the palette entries }
    pf1Bit, pf4Bit, pf8Bit:
      begin
        Bitmap.Palette := GrayPaletteEntries(Bitmap.Palette);
      end;
    { true color - will reduce to 8-bit palette (slower but saves memory) }
    pf15Bit, pf16Bit:
      begin
        raise
          Exception.Create('Not implemented! I am tired! Try promoting the bitmap to pf24/32bit before calling the function!');
      end;
    pf24Bit, pf32Bit:
      begin
        Dest := TBitmap.Create;
        try
          Dest.PixelFormat := pf8Bit;
          Dest.Width := Bitmap.Width;
          Dest.Height := Bitmap.Height;
          Dest.Palette := BuildGrayPalette(pf8bit);
          GetScanLineProperties(Dest, Pointer(DstRow), DstDif);
          if Bitmap.PixelFormat = pf24bit then
            bpp := 3
          else
            bpp := 4;
          for y := 0 to Pred(Bitmap.Height) do
          begin
            for x := 0 to Pred(Bitmap.Width) do
              DstRow[x] := (SrcRow[x * bpp] + SrcRow[x * bpp + 1] + SrcRow[x * bpp +
                2]) div 3;
            Inc(Integer(SrcRow), SrcDif);
            Inc(Integer(DstRow), DstDif);
          end;
          Bitmap.Assign(Dest);
        finally
          Dest.Free;
        end;
      end;
  end;
end;

procedure GrayGraphic(Graphic: TGraphic);
var
  Work: TBitmap;
begin
  Work := TBitmap.Create;
  try
    // the majority of TGraphic class knows how to assign itself to bitmaps (method AssignTo)
    Work.Assign(Graphic);
    if Work.PixelFormat in [pf15Bit, pf16Bit] then
      Work.PixelFormat := pf32Bit; // 32-bit bitmaps are the fastest true color
    GrayBitmap(Work);
    Graphic.Assign(Work);
    Graphic.Modified := True;
  finally
    Work.Free;
  end;
end;

{ TForm1 }

procedure TForm1.btnOpenClick(Sender: TObject);
begin
  if OpenPic.Execute then
    Image1.Picture.LoadFromFile(OpenPic.FileName);
end;

procedure TForm1.btnGrayBitmapClick(Sender: TObject);
begin
  GrayBitmap(Image1.Picture.Graphic as TBitmap);
end;

procedure TForm1.btnGrayGraphicClick(Sender: TObject);
begin
  GrayGraphic(Image1.Picture.Graphic);
end;

end.

---- FORM AS TEXT ----- COPY AND PAST IT TO NOTEPAD AND SAVE AS UNIT1.DFM -----

object Form1: TForm1
  Left = 290
    Top = 129
    Width = 696
    Height = 480
    Caption = 'Form1'
    Color = clBtnFace
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    OldCreateOrder = False
    PixelsPerInch = 96
    TextHeight = 13
    object Image1: TImage
    Left = 88
      Top = 8
      Width = 225
      Height = 209
      AutoSize = True
  end
  object btnOpen: TBitBtn
    Left = 8
      Top = 8
      Width = 75
      Height = 25
      Caption = '&Open Picture'
      TabOrder = 0
      OnClick = btnOpenClick
  end
  object btnGrayBitmap: TBitBtn
    Left = 8
      Top = 40
      Width = 75
      Height = 25
      Caption = '&Gray Bitmap'
      TabOrder = 1
      OnClick = btnGrayBitmapClick
  end
  object btnGrayGraphic: TBitBtn
    Left = 8
      Top = 72
      Width = 75
      Height = 25
      Caption = '&Gray Graphic'
      TabOrder = 2
      OnClick = btnGrayGraphicClick
  end
  object OpenPic: TOpenPictureDialog
    Left = 32
      Top = 136
  end
end

The form has three buttons. The first will load a picture and show it in the Image control. The second will try to gray the graphic stored in the picture property of the TImage as if it was a Bitmap (it will fail if it isn't a Bitmap). And the third will call the GrayGraphic which will work for bitmaps and other compatible TGraphic descendants.

Try to load Jpegs to see taht the code work even with other TGraphics. If you have other third-party supplied, and fully working TGraphic descendant, try adding them to the unit1 (TGifImage for example), and you'll see that it also works with them.

I hope that you can get some good things out of this article (ScanLine manipulation, bitmap format information, TGraphic relationships, etc.) or that it proves useful to you.