Save a TBitmap to a WBMP file (Views: 29)
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; |