Mega Code Archive
How to save a TBitmap to a WBMP file
<![CDATA[
Title: How to save a TBitmap to a WBMP file.
Question: 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;
Enjoy!
]]>