BMP monochrome basic info needed.

[cozturk]

Only needed for monochrome bmp file. TImage etc. not available for now.

I must generate a monochrome bmp file by pixel by pixel.
How can I make a bmp file writing byte by byte for each pixel?

Plot, unplot must available for each pixel.

This is an electronics project with 128x64 pixel graphic LCD .

Pc will send a picture to device....

[Kambiz]

You may find the following unit useful:

Code: Select all

unit MonoBits;

interface

uses
  Windows, Classes, Graphics, SysUtils;

type
  TMonoBits = class(TPersistent)
  private
    fBits: PByteArray;
    fWidth: Integer;
    fHeight: Integer;
    fByteSize: Integer;
    fRowByteSize: Integer;
    function GetBits(X, Y: Integer): Boolean;
    procedure SetBits(X, Y: Integer; Value: Boolean);
  protected
    procedure GetBitAddr(X, Y: Integer; var Ofs: Integer; var Mask: Byte);
  public
    constructor Create(AWidth, AHeight: Integer); reintroduce;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure AssignTo(Dest: TPersistent); override;
    procedure Blackness;
    procedure Whiteness;
    property Width: Integer read fWidth;
    property Height: Integer read fHeight;
    property Bits[X, Y: Integer]: Boolean read GetBits write SetBits; default;
  end;

implementation

{ TMonoBits }

constructor TMonoBits.Create(AWidth, AHeight: Integer);
begin
  fWidth := AWidth;
  fHeight := AHeight;
  fRowByteSize := AWidth div 8;
  if (AWidth mod 8) <> 0 then
    Inc(fRowByteSize);
  fByteSize := fRowByteSize * fHeight;
  ReallocMem(fBits, fByteSize);
end;

destructor TMonoBits.Destroy;
begin
  ReallocMem(fBits, 0);
  inherited Destroy;
end;

procedure TMonoBits.GetBitAddr(X, Y: Integer; var Ofs: Integer; var Mask: Byte);
begin
  Assert((X >= 0) and (X < fWidth) and (Y >= 0) and (Y < fHeight));
  Ofs := (fRowByteSize * Y) + (X div 8);
  Mask := $80 shr (X mod 8);
end;

function TMonoBits.GetBits(X, Y: Integer): Boolean;
var
  Ofs: Integer;
  Mask: Byte;
begin
  GetBitAddr(X, Y, Ofs, Mask);
  Result := ByteBool(fBits[Ofs] or Mask);
end;

procedure TMonoBits.SetBits(X, Y: Integer; Value: Boolean);
var
  Ofs: Integer;
  Mask: Byte;
begin
  GetBitAddr(X, Y, Ofs, Mask);
  if Value then
    fBits[Ofs] := fBits[Ofs] or Mask
  else
    fBits[Ofs] := fBits[Ofs] and not Mask;
end;

procedure TMonoBits.Assign(Source: TPersistent);
begin
  if Source is TMonoBits then
  begin
    fWidth := TMonoBits(Source).fWidth;
    fHeight := TMonoBits(Source).fHeight;
    fByteSize := TMonoBits(Source).fByteSize;
    fByteSize := TMonoBits(Source).fRowByteSize;
    ReallocMem(fBits, fByteSize);
    Move(TMonoBits(Source).fBits^, fBits^, fByteSize);
  end
  else
    inherited Assign(Source);
end;

procedure TMonoBits.AssignTo(Dest: TPersistent);
var
  Y: Integer;
  P: Pointer;
begin
  if Dest is TBitmap then
  begin
    TBitmap(Dest).Width := fWidth;
    TBitmap(Dest).Height := fHeight;
    TBitmap(Dest).PixelFormat := pf1bit;
    for Y := 0 to fHeight - 1 do
    begin
      P := TBitmap(Dest).ScanLine[Y];
      Move(fBits[Y * fRowByteSize], p^, fRowByteSize);
    end;
  end
  else
    inherited AssignTo(Dest);
end;

procedure TMonoBits.Blackness;
begin
  FillChar(fBits, fByteSize, $00);
end;

procedure TMonoBits.Whiteness;
begin
  FillChar(fBits, fByteSize, $FF);
end;

end.

After setting bits of a TMonoBits instance, simply assign it to a bitmap to have the monochorome bitmap image.

Code: Select all

procedure TForm1.Button1Click(Sender: TObject);
var
  MonoBits: TMonoBits;
  X, Y: Integer;
begin
  MonoBits := TMonoBits.Create(128, 128);
  try
    for Y := 0 to MonoBits.Height - 1 do
      for X := 0 to MonoBits.Width - 1 do
        MonoBits[X, Y] := (X * Y < 2048);
    Image1.Picture.Bitmap.Assign(MonoBits);
  finally
    MonoBits.Free;
  end;
end;

By the way, sorry for the last night. I was not behind my computer.

[cozturk]

Thank you very much Kambiz
unit MonoBits very useful for me.

[Kambiz]

I'm glad that could be helful.