unit uBMP; interface const cWidth=1280; cHeight=1024; type TRGB=record r,g,b: byte; end; TPal=array[0..255] of TRGB; PLine=^TLine; TLine=array[0..cWidth-1]of byte; PRect=^TRect; TRect=array[0..cHeight-1]of PLine; TBMP=object private constructor Create(w,h: LongInt); procedure LoadData(var f: file; dWidth, dHeight: longint; BitCount, Compression: word); procedure LoadMS(var f: file); procedure LoadOS2(var f: file); public width,height: LongInt; pal: TPal; pic: PRect; destructor Destroy; procedure LoadFromFile(fn: string); end; implementation type TBMPFileHeader=record ID: array[0..1] of char; Size: longint; { * 4 of file } Reserved: longint; { = 0 } Offset: longint; end; TmsBMPInfoHeader=record Size: longint; { of TBMPInfoHeader ( = 40 ) } Width: longint; Height: longint; Planes: word; { = 1 } BitCount: word; Compression: longint; { 0: RGB, 1: RLE8, 2: RLE4 } SizeImage: longint; { of Image } XPelsPerMeter: longint; YPelsPerMeter: longint; ColorUsed: longint; ColorImportant: longint; end; TBGRA=record b,g,r,a: byte; end; TmsBMPInfo=record Header: TmsBMPInfoHeader; Colors: array[byte] of TBGRA; end; Tos2BMPInfoHeader=record Size: longint; { of Tos2BMPHeader ( = 12 ) } Width: word; Height: word; Planes: word; { = 1 } BitCount: word; end; TBGR=record b,g,r: byte; end; Tos2BMPInfo=record Header: Tos2BMPInfoHeader; Colors: array[byte] of TBGR; end; constructor TBMP.Create(w,h: LongInt); var i: LongInt; begin if (pic<>nil) then Destroy; if (w>cWidth)or(h>cHeight) then exit; GetMem(pic,4*Height); for i:=0 to height-1 do GetMem(pic^[i],width); end; destructor TBMP.Destroy; var i: LongInt; begin if (pic=nil) then exit; for i:=0 to height-1 do FreeMem(pic^[i],width); FreeMem(pic,4*height); pic:=nil; end; procedure TBMP.LoadData(var f: file; dWidth, dHeight: longint; BitCount, Compression: word); var y: LongInt; r: word; begin if (BitCount<>8)or(Compression>0) then exit; Create(Width,Height); for y:=Height-1 downto 0 do BlockRead(f,pic^[y]^[0],Width,r); end; procedure TBMP.LoadMS(var f: file); var Info: TmsBMPInfo; r: word; i,z: longint; begin Info.Header.Size:=40; blockread(f,Info.Header.Width,sizeof(TmsBMPInfoHeader)-4,r); if (Info.Header.BitCount<=8) then begin if (Info.Header.ColorUsed=0) then z:=1 shl Info.Header.BitCount else z:=Info.Header.ColorUsed; blockread(f,Info.Colors,z*sizeof(TBGRA),r); for i:=0 to z-1 do begin pal[i].r:=Info.Colors[i].r shr 2; pal[i].g:=Info.Colors[i].g shr 2; pal[i].b:=Info.Colors[i].b shr 2; end; fillchar(pal[z].r,3*(256-z),0); end; LoadData(f,Info.Header.Width,Info.Header.Height,Info.Header.BitCount,Info.Header.Compression); end; procedure TBMP.LoadOS2(var f: file); var Info: Tos2BMPInfo; r: word; i,z: longint; begin Info.Header.Size:=12; blockread(f,Info.Header.Width,sizeof(Tos2BMPInfoHeader)-4,r); if (Info.Header.BitCount<=8) then begin z:=1 shl Info.Header.BitCount; blockread(f,Info.Colors,z*sizeof(TBGR),r); for i:=0 to z-1 do begin pal[i].r:=Info.Colors[i].r shr 2; pal[i].g:=Info.Colors[i].g shr 2; pal[i].b:=Info.Colors[i].b shr 2; end; fillchar(pal[z].r,3*(256-z),0); end; LoadData(f,Info.Header.Width,Info.Header.Height,Info.Header.BitCount,0); end; procedure TBMP.LoadFromFile(fn: string); var Header: TBMPFileHeader; r: word; z: longint; f: file; begin assign(f,fn); reset(f,1); blockread(f,Header,sizeof(TBMPFileHeader),r); if (Header.ID[0]='B')and(Header.ID[1]='M') then begin blockread(f,z,4,r); if (z=12) then begin LoadOS2(f); end; if (z=40) then begin LoadMS(f); end; end; close(f); end; end. ------------------- Subject: Bitmap Unit Date: Thu, 25 Jun 1998 23:46:08 +0200 From: bj To: Franz Glaser Hallo, wie gewünscht ist hier meine Bitmap-Unit, in diesem Entwicklungsstadium kann sie allerdings nur 8Bit Bilder, ohne Kompression, im MS und OS2 Format laden. Die Funktionsweise ist schnell erklärt, man ruft die Prozedur LoadFromFile vom Objekt TBMP auf und hat danach in den Variablen pal und pic die Palette und die Bilddaten des Bitmap und kann mit diesen machen was man will.. Wenn sie Unit veröffentlichen oder sie Ihnen weitergeholfen hat würde ich mich über eine weitere Mail freuen, auch um eventuelle Verbesserungen an der Unit an Sie weiterzugeben. MfG Björn Rohreit -------------------------------------------------------------