Category : Pascal Source Code
Archive   : XLIBPAS2.ZIP
Filename : XBMP2.PAS

 
Output of file : XBMP2.PAS contained in archive : XLIBPAS2.ZIP
unit XBMP2;
{ ************************************************
** BMP Decoding and Encoding procedures **
** for Borland/Turbo Pascal 7.0 **
** **
** Written by Tristan Tarrant, 1994 **
** **
************************************************ }

interface

uses
Dos;

type
BMPLineProcType = procedure( Var pixels; line, width : integer );
BMPPixelProcType = function( x, y : integer) : integer;
TByteArray = Array[0..0] of byte;
TIntArray = Array[0..0] of integer;

Var
{ Pointers to custom procedures to deal with lines. BMPOutLineProc
is called with three parameters : an untyped var, containing
the uncompressed data, and two integer values, containing the
line number and the width of the line.
BMPInPixelProc should instead return a pixels value, -1 if at the
end of the data. }

BMPOutLineProc : BMPLineProcType;
BMPInPixelProc : BMPPixelProcType;
BMPPalette : array[0..767] of byte;

function SaveBMP( f : string; width, depth : integer; var palette ) : boolean;
function LoadBMP( f : string ) : boolean;

implementation

type
BMPHeader = record
id : array[1..2] of char;
filesize,
reserved,
headersize,
infoSize,
wid,
hgt : longint;
biPlanes, bits : integer;
biCompression,
biSizeImage,
biXPelsPerMeter,
biYPelsPerMeter,
biClrUsed,
biClrImportant : longint;
end;

BMPRGB = record
b, g, r, f : byte;
end;

function DecodeBMP( var f : file ) : boolean;
var
BMPHead : BMPHeader;
hgt, wid, index : integer;
r, g, b : byte;
ScreenLine : pointer;
col : BMPRGB;

begin
blockread( f, BMPHead, SizeOf( BMPHead ) );
for index:=0 to 255 do
begin
blockread( f, col, SizeOf( BMPRGB ) );
BMPPalette[index*3] := col.r shr 2;
BMPPalette[index*3+1] := col.g shr 2;
BMPPalette[index*3+2] := col.b shr 2;
end;
wid := BMPHead.wid;
if wid mod 4<>0 then wid := wid + 4 - wid mod 4;

GetMem( ScreenLine, wid );
hgt := BMPHead.hgt-1;
for index:=hgt downto 0 do
begin
blockread( f, ScreenLine^, wid );
BMPOutLineProc( ScreenLine^, index, wid );
end;
DecodeBMP := true;
end;

function LoadBMP( F : string ) : boolean;
var
D: DirStr;
N: NameStr;
E: ExtStr;
FileHandle : File;
begin
FSplit( F, D, N, E );
if E='' then E:='.BMP';
F := D+N+E;
{$I-}
assign( FileHandle, F );
reset( FileHandle, 1 );
{$I+}
if ioresult = 0 then
LoadBMP := DecodeBMP( FileHandle )
else
LoadBMP := false;
{$I-}
close( FileHandle );
{$I+}
end; { LoadBMP }

function EncodeBMP( var f : file; width, depth : integer; var palette ) : boolean;
var
BMPHead : BMPHeader;
hgt, wid, index, index2 : integer;
r, g, b : byte;
ScreenLine : pointer;
col : BMPRGB;
ThePalette : TByteArray absolute palette;

begin
fillchar( BMPHead, sizeof(BMPHeader),0 );
with BMPHead do
begin
id := 'BP';
headersize := 1078;
filesize := headersize + width*depth;
wid := width;
hgt := depth;
infosize := $28;
bits := 8;
biplanes := 1;
biCompression := 0;
end;

blockwrite( f, BMPHead, SizeOf( BMPHead ) );
for index:=0 to 255 do
begin
col.r := ThePalette[index*3] shl 2;
col.g := ThePalette[index*3+1] shl 2;
col.b := ThePalette[index*3+2] shl 2;
blockwrite( f, col, SizeOf( BMPRGB ) );
end;
wid := width;
if wid mod 4<>0 then wid := wid + 4 - wid mod 4;
GetMem( ScreenLine, wid );
hgt := BMPHead.hgt-1;
for index:=hgt downto 0 do
begin
fillchar( ScreenLine^,wid,0);
for index2 := 0 to width-1 do
TByteArray(ScreenLine^)[index2] := BMPInPixelProc(index2,index);
blockwrite( f, ScreenLine^, wid );
end;
EncodeBMP := true;
end;

function SaveBMP( f : string; width, depth : integer; var palette ) : boolean;
var
D: DirStr;
N: NameStr;
E: ExtStr;
FileHandle : File;
begin
FSplit( F, D, N, E );
if E='' then E:='.BMP';
F := D+N+E;
{$I-}
assign( FileHandle, F );
rewrite( FileHandle, 1 );
{$I+}
if ioresult = 0 then
SaveBMP := EncodeBMP( FileHandle, width, depth, palette )
else
SaveBMP := false;
{$I-}
close( FileHandle );
{$I+}
end;

end.


  3 Responses to “Category : Pascal Source Code
Archive   : XLIBPAS2.ZIP
Filename : XBMP2.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/