bmpgrayu.pas

(Delphi) converting grayscale pallete code. Bitmaps can be converted to grayscale palette.

unit BMPGrayU;

{ Demo zur Demonstration von Direktzugriffen auf eine Bitmap

  Peter Haas, 1997-1998

  Delphi 1 bis 4

  EMail:     [e-mail],
  HomePage:  http://home.t-online.de/home/PeterJHaas/delphi.htm }

interface

uses
  WinTypes, WinProcs, SysUtils, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, ExtCtrls;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    Button1: TButton;
    Button2: TButton;
    Image4: TImage;
    OpenDialog1: TOpenDialog;
    Button3: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private-Deklarationen }
    FIsPicture     : Boolean;
    FIsGrayPicture : Boolean;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation
uses
  BmpGrD12;

{$R *.DFM}

procedure TForm1.Button3Click(Sender: TObject);
begin
  with OpenDialog1 do begin
    if Execute then begin
      Image1.Picture.LoadFromFile(Filename);
      FIsPicture:=True;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  ABitmap : TBitmap;
begin
  if Not FIsPicture then Exit;
  ABitmap:=TBitmap.Create;
  try
    if ConvertToGrayBitmap(Image1.Picture.Bitmap,ABitmap) then begin
      FIsGrayPicture:=True;
      Image2.Picture.Bitmap.Assign(ABitmap);
    end;
  finally
    ABitmap.Free;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  ABitmap : TBitmap;
  APalette : TFullPalette;
  i : Integer;
  x : Double;
begin
  if Not FIsGrayPicture then Exit;
  { Segment 0 }
  x:=256 / 42;
  for i:=0 to 41 do with APalette[i] do begin     {   0 ..  41 }
    rgbBlue :=0;
    rgbGreen:=Trunc(i*x);
    rgbRed  :=255;
  end;
  { Segment 1 }
  x:=256 / 43;
  for i:=0 to 42 do with APalette[i+42] do begin  {  42 ..  84 }
    rgbBlue :=0;
    rgbGreen:=255;
    rgbRed  :=Trunc((42-i)*x);
  end;
  { Segment 2 }
  x:=256 / 43;
  for i:=0 to 42 do with APalette[i+85] do begin  {  85 .. 127 }
    rgbBlue :=Trunc(i*x);
    rgbGreen:=255;
    rgbRed  :=0;
  end;
  { Segment 3 }
  x:=256 / 42;
  for i:=0 to 41 do with APalette[i+128] do begin { 128 .. 169 }
    rgbBlue :=255;
    rgbGreen:=Trunc((41-i)*x);
    rgbRed  :=0;
  end;
  { Segment 4 }
  x:=256 / 43;
  for i:=0 to 42 do with APalette[i+170] do begin { 170 .. 212 }
    rgbBlue :=255;
    rgbGreen:=0;
    rgbRed  :=Trunc(i*x);
  end;
  { Segment 5 }
  x:=256 / 43;
  for i:=0 to 42 do with APalette[i+213] do begin { 213 .. 255 }
    rgbBlue :=Trunc((42-i)*x);
    rgbGreen:=0;
    rgbRed  :=255;
  end;
  ABitmap:=TBitmap.Create;
  try
    if DrawPalette(ABitmap,APalette,Image4.Height) then begin
      Image4.Picture.Bitmap.Assign(ABitmap);
    end;
    ABitmap.Assign(Image2.Picture.Bitmap);
    if ChangePalette(ABitmap,APalette) then begin
      Image3.Picture.Bitmap.Assign(ABitmap);
    end;
  finally
    ABitmap.Free;
  end;
end;

end.