[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]
{$R-}
Unit BMP;
{
ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ
ÛÛÛÝÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÜÞÛÛÛ±±
ÛÛÛÝÛÛ ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ Complete unit for BMP images ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ Aleksandar Dlabac ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ (C)1995. Dlabac Bros. Company ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ ------------------------------ ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ adlabac@urcpg.urc.cg.ac.yu ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ adlabac@urcpg.pmf.cg.ac.yu ÛÛÞÛÛÛ±±
ÛÛÛÝÛÛ ÛÛÞÛÛÛ±±
ÛÛÛÝßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßßÞÛÛÛ±±
ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ±±
±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±±
}
Interface
Type BMPInfoType = Record
Width : longint;
Height : longint;
Colors : longint;
Palette : array [0..255] of Record
Red : byte;
Green : byte;
Blue : byte
End
End;
Procedure ReadBMP (FileName : string);
Function BMPResult : integer;
Function BMPErrorMsg (ErrorCode : integer) : string;
Procedure BMPInfo (var Info : BMPInfoType);
Implementation
Uses Graph;
Const Rasters : array [0..15] of array [0..7] of byte =
((0,0,0,0,0,0,0,0),(128,0,8,0,128,0,8,0),(136,0,34,0,136,0,34,0),
(168,0,42,0,138,0,42,0),(136,34,136,34,136,34,136,34),
(168,136,42,34,168,136,42,34),(170,68,170,68,170,68,170,68),
(170,85,170,85,170,85,170,85),(170,213,170,93,170,213,170,93),
(85,187,85,187,85,187,85,187),(87,119,213,221,117,119,213,221),
(119,221,119,221,119,221,119,221),(87,255,213,255,117,255,213,255),
(119,255,221,255,119,255,221,255),(127,255,247,255,127,255,247,255),
(255,255,255,255,255,255,255,255));
{ This rasters is used for mono image dithering. Whenever program
determines that number of colors available is smaller than number of
colors in picture, picture is shown in mono (1 color) dither. }
Var B : array [1..4] of byte;
K : byte;
BMPError : integer;
I, J : longint;
Colors : longint;
MaxColor : longint;
CoreHeader : Boolean;
BMPFileHeader : Record
BfType : integer; { Signature "BM" ($4D $42) }
BfSize : longint; { File size }
BfReserved1 : integer; { Reserved }
BfReserved2 : integer; { Reserved }
BfOffBits : longint { Data offset address: }
End; { 2 colors $3E }
{ 16 colors $76 }
{ 256 colors $436 }
{ true color $36 }
BMPInfoHeader : Record
BiSize : longint; { $28 - Header length in bytes }
BiWidth : longint; { Picture width }
BiHeight : longint; { Picture height }
BiPlanes : word; { Number of planes }
BiBitCount : word; { Bits per pixel }
BiCompression : longint; { Compression type (0-none) }
BiSizeImage : longint; { Picture size in bytes (can be 0 for no compression) }
BiXPelsPerMeter : longint;
BiYPelsPerMeter : longint;
BiClrUsed : longint;
BiClrImportant : longint
End;
RGBColors : array [0..255] of Record
RGBBlue : byte;
RGBGreen : byte;
RGBRed : byte;
RGBReserved : byte
End;
Procedure PutPix (X,Y,Col:longint);
Var Pix : byte;
Intensity : real;
Begin
If (Y=0) and (Col<>255) then
Write ('');
If X>GetMaxX then Exit;
If Y>GetMaxY then Exit;
If X>BMPInfoHeader.BiWidth-1 then Exit;
If Y>BMPInfoHeader.BiHeight-1 then Exit;
If MaxColor<Colors-1 then
With RGBColors [Col] do
Begin
Intensity:=0.299*RGBRed+0.587*RGBGreen+0.114*RGBBlue;
Intensity:=Intensity/255;
Pix:=Rasters [Round (Intensity*15)][Y and 7];
Pix:=(Pix shr (X and 7)) and 1;
PutPixel (X,Y,Pix);
End
else
PutPixel (X,Y,Col)
End;
Procedure ReadBMP (FileName : string);
Var F : file;
Size : longint;
Begin
Assign (F,FileName);
{$I-}
Reset (F,1);
{$I+}
If IOResult<>0 then
Begin
BMPError:=1;
Exit
End;
Size:=FileSize (F);
If Size<246 then
Begin
BMPError:=2;
Exit
End;
BlockRead (F,BMPFileHeader,14);
If BMPFileHeader.BfType<>$4D42 then
Begin
BMPError:=4;
Exit
End;
If Size<BMPFileHeader.BfSize then
Begin
BMPError:=2;
Exit
End;
BlockRead (F,Size,4);
CoreHeader:=Size=$0C;
BMPInfoHeader.BiSize:=Size;
If Size=$28 then
BlockRead (F,BMPInfoHeader.BiWidth,$24)
else
If Size=$0C then
With BMPInfoHeader do
Begin
BlockRead (F,BiWidth,8);
BiCompression:=0;
BiSizeImage:=0;
BiXPelsPerMeter:=0;
BiYPelsPerMeter:=0;
BiClrUsed:=0;
BiClrImportant:=0
End
else
Begin
BMPError:=5;
Exit
End;
Case BMPInfoHeader.BiBitCount of
1 : Colors:=2;
4 : Colors:=16;
8 : Colors:=256;
24 : Colors:=16777216;
else
Begin
BMPError:=6;
Exit
End
End;
If GetGraphMode<0 then
Begin
BMPError:=7;
Exit
End;
If Colors<=256 then
For I:=0 to Colors-1 do
Begin
SetPalette (I,I);
If Colors=2 then
With RGBColors [I] do
Begin
RGBBlue:=I*255;
RGBGreen:=I*255;
RGBRed:=I*255;
RGBReserved:=0
End
else
If CoreHeader then
Begin
BlockRead (F,RGBColors [I],3);
RGBColors [I].RGBReserved:=0
End
else
BlockRead (F,RGBColors [I],4);
With RGBColors [I] do
SetRGBPalette (I,RGBRed div 4,RGBGreen div 4,RGBBlue div 4)
End;
If GetMaxColor+1<Colors then
MaxColor:=1
else
MaxColor:=GetMaxColor;
If MaxColor=1 then
Begin
SetRGBPalette (0,0,0,0);
SetRGBPalette (1,63,63,63)
End;
Seek (F,BMPFileHeader.BfOffBits);
With BMPInfoHeader do
For J:=BiHeight-1 downto 0 do
Begin
I:=0;
Repeat
If Colors<=256 then
BlockRead (F,B [1],4)
else
BlockRead (F,B [1],3);
Case BiBitCount of
1 : Begin
K:=1;
Repeat
If B [K] and $80>0 then
PutPix (I,J,1)
else
PutPix (I,J,0);
Inc (I);
B [K]:=B [K] shl 1;
If I mod 8=0 then Inc (K)
Until K=5
End;
4 : For K:=1 to 4 do
Begin
PutPix (I,J,(B [K] and $F0) shr 4);
Inc (I);
PutPix (I,J,B [K] and $0F);
Inc (I)
End;
8 : For K:=1 to 4 do
Begin
PutPix (I,J,B [K]);
Inc (I)
End;
24 : PutPix (I,J,longint (B [3])*65536+B [2]*256+B [1])
End
Until I>BiWidth-1;
If Colors>256 then
For K:=1 to (I*3) and 3 do
BlockRead (F,B[1],1)
End;
BMPError:=0
End;
Function BMPResult : integer;
Begin
BMPResult:=BMPError;
BMPError:=0
End;
Function BMPErrorMsg (ErrorCode : integer) : string;
Var Temp : string;
Begin
Case ErrorCode of
0 : Temp:='No error';
1 : Temp:='Error opening file';
2 : Temp:='File too short';
3 : Temp:='File not loaded';
4 : Temp:='Not a BMP file';
5 : Temp:='Invalid header';
6 : Temp:='Invalid number of colors';
7 : Temp:='Graphics mode not initialized';
else Temp:='Unknown error'
End;
BMPErrorMsg:=Temp;
End;
Procedure BMPInfo (var Info : BMPInfoType);
Var I : integer;
Begin
With Info do
Begin
Width:=0;
Height:=0;
Colors:=0;
If BMPError=0 then
With BMPInfoHeader do
Begin
Width:=BiWidth;
Height:=BiHeight;
Case BiBitCount of
1 : Colors:=2;
4 : Colors:=16;
8 : Colors:=256;
24 : Colors:=16777216;
else Colors:=0
End;
For I:=0 to Info.Colors-1 do
With Palette [I], RGBColors [I] do
Begin
Red:=RGBRed;
Green:=RGBGreen;
Blue:=RGBBlue
End
End
End
End;
Begin
BMPError:=3
End.
{ ---------------------- Demo program ---------------------- }
Program LoadBMP;
Uses Crt, Graph, BMP;
Const VGA256 = False;
Var Gd, Gm, Result : integer;
AutoDetectPointer : pointer;
{$F+}
Function DetectCard:integer;
Var DetectedDriver, SuggestedMode : integer;
Begin
DetectGraph (DetectedDriver,SuggestedMode);
If (DetectedDriver=VGA) or (DetectedDriver=MCGA) then
DetectCard:=grOk
else
DetectCard:=grError
End;
{$F-}
Procedure InitGraph256;
Var Gd, Gm, ErrorCode : integer;
Begin
AutoDetectPointer:=@DetectCard;
Gd:=InstallUserDriver ('VGA256',AutoDetectPointer);
If GraphResult<>grOk then
Begin
Writeln ('Error installing driver');
Halt
End;
Gd:=Detect;
InitGraph (Gd,Gm,'');
ErrorCode:=GraphResult;
If ErrorCode<>grOk then
Begin
Writeln ('Error: ',GraphErrorMsg (ErrorCode));
Halt
End
End;
Begin
If VGA256 then
InitGraph256
else
Begin
DetectGraph (Gd,Gm);
InitGraph (Gd,Gm,'')
End;
ReadBMP ('\WINDOWS\TARTAN.BMP');
Write (#7);
Result:=BMPResult;
If Result=0 then Repeat Until ReadKey<>'';
CloseGraph;
Writeln ('BMP status = ',BMPErrorMsg (Result))
End.
[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]