{ Модуль, предназначенный для чтения BMP картинок из файла. Поддерживаются 16-тицветные картинки без сжатия } Unit bmp; interface Procedure BMPDisplay(const FileName: String; x,y: Integer; Kill: Boolean); 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 ('Монохромный режим не поддерживается.'); End; Procedure Display4 (Var f : File; const BitMapHeader : TBitMapHeader; x,y: Integer; Kill: Boolean); 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 ('В данном видеорежиме невозможно отображение 16 цветов.'); 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 := x+1; {(GetMaxX - biWidth) div 2;} BeginY := y+biHeight;{GetMaxY - (GetMaxY - biHeight) div 2;} EndY := y+1; 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 Not Kill Then Begin 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 Else Begin If TwoPixel shr 4 <> Black then { Черный цвет считаем прозрачным } PutPixel(CurrentX,j,Black); Inc(CurrentX); If TwoPixel and 15 <> Black then PutPixel(CurrentX,j,Black); Inc(CurrentX); End; End; End; FreeMem (Line,number+1); End; Procedure Display8 (Var f : File; const BitMapHeader : TBitMapHeader); Begin WriteLn ('Режим 256 цветов не поддерживается.'); End; Procedure Display24 (Var f : File; const BitMapHeader : TBitMapHeader); Begin WriteLn ('Режим 24 битного цвета не поддерживается.'); End; Procedure BMPDisplay(const FileName: String; x,y: Integer; Kill: Boolean); Var f: File; BitMapHeader : TBitMapHeader; Begin Assign(f,FileName); {$I-} FileMode:=0; { Открываем файл для чтения } Reset(f,1); {$I+} If IOResult<>0 Then Begin WriteLn ('Нет такого файла.'); Exit; End; BlockRead(f,BitMapHeader,SizeOf(BitMapHeader)); With BitMapHeader do Begin If (bfType<>19778) or (bfReserved<>0) or (biPlanes<>1) then Begin WriteLn ('Неверный формат BMP файла.'); Close(f); Exit; End; If biCompression<>0 Then Begin WriteLn ('Файл сохранен со сжатием данных.'); Close(f); Exit; End; {ClearDevice;} Case biBitCount of 1 : Display1 (f, BitMapHeader); 4 : Display4 (f, BitMapHeader, x,y, Kill); 8 : Display8 (f, BitMapHeader); 24 : Display24 (f, BitMapHeader); else Begin WriteLn ('Неверный формат BMP файла.'); Close(f); Exit; End; End; End; Close(f); End; End.