Save a TBitmap to a WBMP file

Problem/Question/Abstract:

I needed to save WBMP files for WAP applications. Here is the way I found to do it...

Answer:

Note that the bitmap contained in the TBitmap must be black and white.

function BitmapToWBMP(Bmp: TBitmap; Filename: string): Boolean;
var
  F: file;
  Buf: array[0..256] of Byte;
  BufLen: LongInt;
  BPos: LongInt;
  B: LongInt;
  X: LongInt;
  Y: LongInt;
  procedure Write_To_Header(L: LongInt);
  var
    Extra: LongInt;
    B: Byte;
  begin
    Extra := 0;
    while L >= 128 do
    begin
      Inc(Extra);
      Dec(l, 128);
    end;
    if Extra > 0 then
    begin
      B := 128 + Extra;
      BlockWrite(F, B, 1);
    end;
    B := l;
    BlockWrite(F, B, 1);
  end;
begin
  Result := False;
  if Bmp = nil then
    EXIT;
  if Bmp.Empty then
    EXIT;
  if Bmp.Width = 0 then
    EXIT;
  if Bmp.Height = 0 then
    EXIT;
  AssignFile(F, FileName);
  Rewrite(F, 1);
  if IOResult <> 0 then
    EXIT;
  BufLen := Bmp.Width shr 3 + Byte(Bmp.Width and 7 > 0);
  Write_To_Header(0);
  Write_To_Header(0);
  Write_To_Header(Bmp.Width);
  Write_To_Header(Bmp.Height);
  for Y := 0 to Bmp.Height - 1 do
  begin
    FillChar(Buf, SizeOf(Buf), 0);
    BPos := 0;
    B := 128;
    for X := 0 to Bmp.Width - 1 do
    begin
      if Bmp.Canvas.Pixels[X, Y] <> clBlack then
        Inc(Buf[BPos], B);
      if B > 1 then
        B := B shr 1
      else
      begin
        B := 128;
        Inc(BPos);
      end;
    end;
    BlockWrite(F, Buf, BufLen);
  end;
  CloseFile(F);
  Result := True;
end;