Unit bmp;
interface
Procedure BMPDisplay(const FileName: String);
implementation
Uses Graph;
Type
TBitMapHeader =
Record
bfType : Word; { Метка файла BM }
bfSize : LongInt; { Длина файла в байтах }
bfReserved : LongInt; { Резервные должны быть = 0 }
bfOffBits : LongInt; { Смещение области данных }
biSize : LongInt; { Длина BITMAP_INFO заголовка }
biWidth : LongInt; { Ширина изображения в пикселах }
biHeight : LongInt; { Высота изображения в пикселах }
biPlanes : Word; { Цветовые плоскости = 1 }
biBitCount : Word; { Количество битов на пиксел 1,4,8,24 }
biCompression : LongInt; { Тип сжатия данных }
biSizeImage : LongInt; { Размер изображения в байтах }
biXPelsPerMeter : LongInt; { Разрешение по горизонтали }
biYPelsPerMeter : LongInt; { Разрешение по вертикали }
biClrUsed : LongInt; { Количество используемых цветов }
biClrImportant : LongInt; { Количество основных цветов }
End;
TRGBQuad = { Описание цвета }
Record
rgbBlue, { Интенсивность голубого }
rgbGreen, { Интенсивность зеленого }
rgbRed, { Интенсивность красного }
rgbReserved : Byte; { Резервный }
End;
Type TByteArray = Array[0..50000] of byte;
Procedure Display1 (Var f : File; const BitMapHeader : TBitMapHeader);
Begin
WriteLn ('Monocrome mode not support.');
End;
Procedure Display4 (Var f : File; const BitMapHeader : TBitMapHeader);
Var i,j : Integer;
Var RGBQuad : TRGBQuad;
Var TwoPixel : Byte;
Var Black : Byte;
Var Line : ^TByteArray;
Var number : Word;
Var BeginX,BeginY,EndY : Integer;
CurrentX: Integer;
Begin
If GetMaxColor < 15 then
Begin
WriteLn ('This Graph Mode not paint 16 colors.');
Exit;
End;
Black := 16;
With BitMapHeader do
begin
For i:= 0 to 15 do { Чтение и изменение палитры }
Begin
BlockRead(f,RGBQuad,SizeOf(RGBQuad));
If (LongInt(RGBQuad)=0) then Black := i;
With RGBQuad do
SetRGBPalette(i, rgbRed shr 2, rgbGreen shr 2, rgbBlue shr 2);
SetPalette(i,i);
End;
Number := (biWidth div 2 + 3) and not 3; { Длина одной строки в байтах }
BeginX := (GetMaxX - biWidth) div 2;
BeginY := GetMaxY - (GetMaxY - biHeight) div 2;
EndY := BeginY+1-biHeight;
End;
GetMem (Line,number+1); { Выводим изображение }
For j:=BeginY downto EndY do
Begin
BlockRead(f,Line^[1],number);
CurrentX := BeginX;
For i:=1 to number do
Begin
TwoPixel := Line^[i];
If TwoPixel shr 4 <> Black then { Черный цвет считаем прозрачным }
PutPixel(CurrentX,j,TwoPixel shr 4);
Inc(CurrentX);
If TwoPixel and 15 <> Black then
PutPixel(CurrentX,j,TwoPixel and 15);
Inc(CurrentX);
End;
End;
FreeMem (Line,number+1);
End;
Procedure Display8 (Var f : File; const BitMapHeader : TBitMapHeader);
Begin
WriteLn ('Mode of 256 colors no support.');
End;
Procedure Display24 (Var f : File; const BitMapHeader : TBitMapHeader);
Begin
WriteLn ('Mode of 24 bit color not support.');
End;
Procedure BMPDisplay(const FileName: String);
Var f: File;
BitMapHeader : TBitMapHeader;
Begin
Assign(f,FileName);
{$I-}
FileMode:=0; { Открываем файл для чтения }
Reset(f,1);
{$I+}
If IOResult<>0 Then
Begin
WriteLn ('File not found.');
Exit;
End;
BlockRead(f,BitMapHeader,SizeOf(BitMapHeader));
With BitMapHeader do
Begin
If (bfType<>19778) or (bfReserved<>0) or (biPlanes<>1) then
Begin
WriteLn ('No format of BMP-file.');
Close(f);
Exit;
End;
If biCompression<>0 Then
Begin
WriteLn ('File has been packed.');
Close(f);
Exit;
End;
ClearDevice;
Case biBitCount of
1 : Display1 (f, BitMapHeader);
4 : Display4 (f, BitMapHeader);
8 : Display8 (f, BitMapHeader);
24 : Display24 (f, BitMapHeader);
else
Begin
WriteLn ('No format of BMP-file.');
Close(f);
Exit;
End;
End;
End;
Close(f);
End;
End.
Этот модуль читает только 16-тиразрядные а хотелось бы побольше! Помогите если можете!!!