UNIT BMP; INTERFACE const Red=0; Green=1; Blue=2; PROCEDURE SBMI(FILEname:string; X,Y:Word; FDR:Integer); implementation uses dos,graph; type TPaletteEntry = record {⨯ } B,G,R:Byte; Flags:Byte; end; TBitmapFileHeader = record bfType :word; bfsize :longint; bfReserved1 :word; bfReserved2 :word; bfOffBits :longint; biSize :longint; biWidth,BiHeight :longint; BiPlanes :word; bibitCount :word; biCompression :longint; biSizeImage :longint; biXPelsPerMeter, biYPelsPerMeter :Longint; biClrUsed, biCLrImportant :longint; end; TpPalArray =array[0..255, red..BLUE] of byte; var F :FILE; { BMP file } bfh :TBitMapFileHeader; { 䠩} Pal : array[0..256] of TPaletteEntry; PROCEDURE OPENFILE(const bitmapname:string); begin assign(f,bitmapname); reset(f,1); end; PROCEDURE CLOSEFILE; begin Close(f); end; PROCEDURE ReadBMPFileHead; begin BlockRead(f,BFH,SizeOf(BFH)); end; PROCEDURE ReadPalette(PalSize:Integer); var c:byte; begin BLOCKREAD(f,Pal,Palsize*4); end; PROCEDURE SetPalette(PalSize:Integer; FirstDacReg:Integer); var Palette : TpPalArray; reg : registers; i : byte; begin If GetMaxColor>256 then exit; for i:=0 to palsize-1 do begin Palette[i,red] := pal[i].r shr 2; Palette[i,green] := pal[i].g shr 2; Palette[i,blue] := pal[i].b shr 2; end; Reg.ah:=$10; Reg.al:=$12; Reg.bx:=FirstDacReg; Reg.cx:=PalSize; Reg.dx:=Ofs(Palette); Reg.es:=Seg(Palette); Intr($10,Reg); end; { 16- K} PROCEDURE ShowImage4(palOffset:Integer; XStart,YStart:Word); var Px,C0,C1 :Byte; Lin4 :array[0..1023] of byte; col : longint; width,height,xt,yt,w2 :word; begin Seek(f,bfh.bfOffbits); width:=bfh.biwidth; height:=bfh.biHeight; while (width mod 8)<>0 do inc(Width); w2 := (bfh.biwidth-1) div 2; for yt:=height-1 downto 0 do begin blockRead(f,lin4,width div 2); for xt:=0 to w2 do begin px:=lin4[xt]; c0:=Px shr 4; Px:=(px shr 4)+(Px shl 4); C1:=Px shr 4; Putpixel(Xstart+xt*2,ystart+yt,c0+PalOffset); PutPixel(Xstart+xt*2+1,ystart+yt,c1+paloffset) end end end; {BIBOD 256} PROCEDURE ShowImage8(palOffset: integer; xstart,Ystart:WORD); type TLin8=record x,y:word; data:array[0..1023] of byte; end; var lin8 : ^TLin8; i : integer; l,col :longint; width,height,xt,yt,sizeP :word; begin width:=bfh.biwidth; height:=bfh.biheight; while (width mod 4)<>0 do inc(width); seek(f,bfh.bfoffbits); sizeP:=sizeof(Tlin8); getmem(lin8,sizep); lin8^.X:=bfh.biwidth-1; lin8^.Y:=0; for yt:= height-1 downto 0 do begin blockRead(f,lin8^.Data,width); for i:=0 to width-1 do putpixel(Xstart+i, Ystart+yt,lin8^.data[i]+palOffset) end; freeMem(lin8,sizep) end; PROCEDURE SBMI(FILEname:string; X,Y:Word; FDR:Integer); var MaxC :longint; xt,yt :word; begin OpenFile(FILEname); ReadBmpFileHead; case bfh.bibitcount of 4: begin readpalette(16); setpalette(16,FDR); showimage4(fdr,x,y); end; 8: begin readpalette(256); setpalette(256,fdr); showimage8(fdr,x,y); end; end; closefile; end; end.