dibtools.pas

(Delphi) Universal dib codes. Usign DIB palettes, dib bitmaps and more

    C,And1:Byte;
    Pal:TLogPalette256;
    Y:Integer;
    Byt,D,E:Byte;
    Plan:Byte;
    BReads:Integer;
    StrSize:Integer;
    BFile:TBufferedFile;
    Pntr:Pointer;

begin
  If ADIB<>nil then
    ADIB.Free;
  ADIB:=nil;
  BFile:=nil;
  try
    BFile:=TBufferedFile.Create (AName,omRead);
  except
    Result:=UDIBFileOpenError;
    BFile.Free;
    Exit;
  end;
  StrSize:=BFile.Str.Size;
  try
    BFile.PreReadBytes (128);
    If BFile.Buffer[0]<>$0A then
    begin
      Result:=UDIBBadFile;
      BFile.Free;
      Exit;
    end;
    Width:=(BFile.Buffer[8]+BFile.Buffer[9]*256)-(BFile.Buffer[4]+BFile.Buffer[5]*256)+1;
    Height:=(BFile.Buffer[10]+BFile.Buffer[11]*256)-(BFile.Buffer[6]+BFile.Buffer[7]*256)+1;
    Ver:=BFile.Buffer[1];
    Planes:=BFile.Buffer[65];
    Bits:=BFile.Buffer[3];
    BPP:=Bits*Planes;
    If UpsideDownDIB then
      ADIB:=TUniDIB.Create (Width,-Height,BPP,SBU_NONE)
    else
      ADIB:=TUniDIB.Create (Width,Height,BPP,SBU_NONE);
    BytesPerLine:=BFile.Buffer[66]+BFile.Buffer[67]*256;
    If ((Ver=2) OR (Ver=4) OR (Ver=5)) AND (BPP<8) then
    begin
      BFile.Pos:=16;
      For C:=0 to 1 SHL BPP do
      begin
        Pal.palEntry[C].peRed:=BFile.ReadByte;
        Pal.palEntry[C].peGreen:=BFile.ReadByte;
        Pal.palEntry[C].peBlue:=BFile.ReadByte;
      end;
      ADIB.SetPalette (Pal);
    end;
    If (Ver=0) OR (Ver=3) then
    begin
      Case BPP of
        8:Move (Std256ColPalette,Pal.palEntry[0],16*SizeOf(TPaletteEntry));
        4:Move (Std16ColPalette,Pal.palEntry[0],16*SizeOf(TPaletteEntry));
        1:Move (Std2ColPalette,Pal.palEntry[0],16*SizeOf(TPaletteEntry));
      end;
      If BPP<=8 then
        ADIB.SetPalette (Pal);
    end;
    Y:=1;
    C:=0;
    BFile.Pos:=128;
    Byt:=0;
    While Y<=Height do
    begin
      Plan:=Planes;
      If UpsideDownDIB then
        ADIB.Seek (0,Y-1)
      else
        ADIB.Seek (0,Height-Y);
      If (Planes<>1) AND (BPP<>24) then
      begin
        FillChar (ADIB.ActPointer^,ADIB.DWordWidth,#0);
        E:=1;
        And1:=1 SHL Bits-1;
      end;
      repeat
        Dec (Plan);
        BReads:=0;
        Pntr:=Pointer(Integer(ADIB.ActPointer)+Plan);
        repeat
          If (Planes=1) OR (BPP=24) then
          begin
            while (C>0) AND (BReads<BytesPerLine) do
            begin
              Byte(Pntr^):=Byt;
              Pntr:=Pointer(Integer(Pntr)+Planes);
              Dec (C);
              Inc (BReads);
            end;
          end
          else
            {4 planes per 1 bit => 16 colors image}
          begin
            while (C>0) AND (BReads<BytesPerLine) do
            begin
              D:=8;
              repeat
                Dec (D,Bits);
                Byte(Pntr^):=Byte(Pntr^) OR (((Byt SHR D) AND And1) SHL (Plan+4*E));
                E:=1-E;
                If E=1 then
                  Pntr:=Pointer(Integer(Pntr)+1);
              until D=0;
              Dec (C);
              Inc (BReads);
            end;
          end;
          If (C=0) AND (BReads<BytesPerLine) then
          begin
            Byt:=BFile.ReadByte;
            If Byt AND $C0=$C0 then
            begin
              C:=Byt AND $3F;
              Byt:=BFile.ReadByte;
            end
            else
              C:=1;
          end;
        until BReads>=BytesPerLine;
      until Plan=0; {Planes-1..0}
      Inc (Y);
    end; {While Y<=PD.Height}
    If (Ver=5) AND (BPP=8) AND
       (StrSize-BFile.FilePos>768) then
    begin
      If BFile.Str.Position>=StrSize-1 then
        BFile.Pos:=BFile.MaxPos-768
      else
        BFile.ReadFromPos (-769);
      If BFile.ReadByte=$0C then
      begin
        For C:=0 to 255 do
        begin
          Pal.palEntry[C].peRed:=BFile.ReadByte;
          Pal.palEntry[C].peGreen:=BFile.ReadByte;
          Pal.palEntry[C].peBlue:=BFile.ReadByte;
        end;
        ADIB.SetPalette (Pal);
      end;
    end;
    BFile.Free;
    Result:=UDIBNoError;
  except
    on EReadError do
      Result:=UDIBReadError
    else
      Result:=UDIBUndefError;
    ADIB.Free;
    ADIB:=nil;
    BFile.Free;
  end;
end;

function UDIBLoadBMP (AName:String;var ADIB:TUniDIB):Integer;
var BFile:TBufferedFile;
    Pal:TLogPalette256;
    BmpOffset:Integer;
    A,B,C:Integer;
    Width,Height:Integer;
    ByteWidth:Integer;
    Planes,Bits:Integer;
    W,Z:Word;
    Compr:Integer;
    PalEn:Integer;
    Rev:Boolean;

  procedure PixelSeek (X,Y:Integer);
  begin
    If Rev then
      ADIB.Seek (X,Height-Y-1)
    else
      ADIB.Seek (X,Y);
  end;

begin
  If ADIB<>nil then
    ADIB.Free;
  ADIB:=nil;
  BFile:=nil;
  try
    BFile:=TBufferedFile.Create (AName,omRead);
  except
    Result:=UDIBFileOpenError;
    BFile.Free;
    Exit;
  end;
  try
    BFile.PreReadBytes (78); {Max. size of BitmapHeader + BitmapInfoHeader
                              (This size is used in OS/2 Bitmap version 2.x)}
    Move (BFile.Buffer[0],W,2);
    Case W of
      0:{Microsoft Windows Bitmap version 1 (Windows 1.x and 2.x)}
        begin
          Width:=BFile.Buffer[2]+BFile.Buffer[3] shl 8;
          Height:=BFile.Buffer[4]+BFile.Buffer[5] shl 8;
          ByteWidth:=BFile.Buffer[6]+BFile.Buffer[7] shl 8;
          Planes:=BFile.Buffer[8];
          Bits:=BFile.Buffer[9];
          BFile.Pos:=10;
          BmpOffset:=10;
          Compr:=0;
          If UpsideDownDIB then
            B:=-Abs(Height)
          else
            B:=Abs(Height);
          ADIB:=TUniDIB.Create (Width,B,Bits,SBU_NONE);
          Rev:=B<>Height;          
          Case Bits of
            8:Move (Std256ColPalette,Pal.palEntry[0],SizeOf(TPaletteEntry) shl 4);
            4:Move (Std16ColPalette,Pal.palEntry[0],SizeOf(TPaletteEntry) shl 4);
            1:Move (Std2ColPalette,Pal.palEntry[0],SizeOf(TPaletteEntry) shl 4);
          end;
          If Bits<=8 then
            ADIB.SetPalette (Pal);
        end;
      Ord('B')+Ord('M') shl 8:
        {Microsoft Windows Bitmap version 3 (Windows 3.x and higher)
         or OS/2 Bitmap version 1.x or 2.x}
        begin
          Move (BFile.Buffer[10],BmpOffset,4);
          Move (BFile.Buffer[14],A,4); {Header size}
          Case A of
            12,64: {OS/2 Bitmap version 1.x or 2.x}
              begin
                Width:=BFile.Buffer[18]+BFile.Buffer[19] shl 8;
                Height:=BFile.Buffer[20]+BFile.Buffer[21] shl 8;
                Planes:=BFile.Buffer[22]+BFile.Buffer[23] shl 8;
                Bits:=BFile.Buffer[24]+BFile.Buffer[25] shl 8;
                If A=64 then
                begin
                  Move (BFile.Buffer[26],Compr,4);
                  Move (BFile.Buffer[30],PalEn,4);
                end
                else
                begin
                  Compr:=0;
                  PalEn:=0;
                end;
              end;
            40: {Microsoft Windows Bitmap version 3}
              begin
                Move (BFile.Buffer[18],Width,4);
                Move (BFile.Buffer[22],Height,4);
                Planes:=BFile.Buffer[26]+BFile.Buffer[27] shl 8;
                Bits:=BFile.Buffer[28]+BFile.Buffer[29] shl 8;
                Move (BFile.Buffer[30],Compr,4);
                Move (BFile.Buffer[46],PalEn,4);
              end;
            else
              {Bad file or new version}
              begin
                Result:=UDIBBadFile;
                BFile.Free;
                Exit;
              end;
          end; {Case A of}
          BFile.Pos:=14+A;
          If PalEn=0 then
            PalEn:=1 SHL Bits;
          ByteWidth:=((Width*Bits+31) shr 5)shl 2;
          If UpsideDownDIB then
            A:=-Abs(Height)
          else
            A:=Abs(Height);
          ADIB:=TUniDIB.Create (Width,A,Bits,SBU_NONE);
          Rev:=A<>Height;
          If Bits<=8 then
            {palette present}
          begin
            B:=BFile.Pos+4*PalEn;
            For A:=0 to PalEn-1 do
            begin
              Pal.palEntry[A].peBlue:=BFile.ReadByte;
              Pal.palEntry[A].peGreen:=BFile.ReadByte;
              Pal.palEntry[A].peRed:=BFile.ReadByte;
              If BmpOffset<B then
              {OS/2 Bitmap has different palette}
                Pal.palEntry[A].peFlags:=0
              else
                Pal.palEntry[A].peFlags:=BFile.ReadByte;
            end;
            ADIB.SetPalette (Pal);
          end;
        end; {W='BM'}
      else
      {Bad file}
      begin
        Result:=UDIBBadFile;
        BFile.Free;
        Exit;
      end;
    end; {Case}
    If Planes<>1 then
    {Bad file or maybe new version}
    begin
      Result:=UDIBBadFile;
      BFile.Free;
      ADIB.Free;
      ADIB:=nil;
      Exit;
    end;
    If BmpOffset<BFile.MaxPos then
      BFile.Pos:=BmpOffset
    else
      BFile.ReadFromPos (BmpOffset);
    BFile.BufSize:=ByteWidth*3+10;
    Case Compr of
      0, {No compression}
      3: {BITFIELDS - I don't know much about it yet}
        begin
          A:=0;
          while A<Height do
          begin
            PixelSeek (0,A);
            BFile.PreReadBytes (ByteWidth+3);
            Move (BFile.Buffer[BFile.Pos],ADIB.ActPointer^,ByteWidth);
            BFile.Pos:=BFile.Pos+((ByteWidth+3) and not 3);
            Inc (A);
          end;
        end;
      1: {RLE8 compression}
        begin
          A:=0;
          PixelSeek (0,A);
          while A<Height do
          begin
            W:=BFile.ReadByte;
            If W=0 then
            begin
              W:=BFile.ReadByte;
              Case W of
                0:{End of line}
                  begin
                    Inc (A);
                    PixelSeek (0,A);
                  end;
                1:{End of bitmap}
                  Break;
                2:{Delta}
                  begin
                    W:=BFile.ReadByte;
                    Inc (A,BFile.ReadByte);
                    PixelSeek (W,A);
                  end;
                else
                begin
                  BFile.PreReadBytes (W+1);
                  Move (BFile.Buffer[BFile.Pos],ADIB.ActPointer^,W);
                  BFile.Pos:=BFile.Pos+((W+1) and not 1);
                  ADIB.ActPointer:=Pointer(Integer(ADIB.ActPointer)+W);
                end;
              end; {Case W of}
            end {If W=0}
            else
              {consecutive pixels}
            begin
              B:=BFile.ReadByte;
              FillChar (ADIB.ActPointer^,W,B);
              ADIB.ActPointer:=Pointer(Integer(ADIB.ActPointer)+W);
            end;
          end;
        end;
      2: {RLE4 compression}
        begin
          A:=0;
          PixelSeek (0,0);
          while A<Height do
          begin
            W:=BFile.ReadByte;
            If W=0 then
            begin
              W:=BFile.ReadByte;
              Case W of
                0:{End of line}
                  begin
                    Inc (A);
                    PixelSeek (0,A);
                  end;
                1:{End of bitmap}
                  Break;
                2:{Delta}
                  begin
                    W:=BFile.ReadByte;
                    Inc (A,BFile.ReadByte);
                    PixelSeek (W,A);
                  end;
                else
                begin
                  For Z:=1 to W do
                  begin
                    If Z and 1=1 then
                    begin
                      B:=BFile.ReadByte;
                      C:=B and $F;
                      B:=B shr 4;
                      ADIB.SetSeqPixel (B);
                    end
                    else
                      ADIB.SetSeqPixel (C);
                  end;
                end;
                If (W shr 1) and 1=1 then
                  BFile.ReadByte;
              end; {Case W of}
            end {If W=0}
            else
              {consecutive pixels}
            begin
              B:=BFile.ReadByte;
              C:=B and $F;
              B:=B shr 4;
              For Z:=1 to W do
                If Z and 1=1 then
                  ADIB.SetSeqPixel (B)
                else
                  ADIB.SetSeqPixel (C);
            end;
          end;
        end;
      else
        {Bad file or unknown compression}
        begin
          Result:=UDIBBadFile;
          BFile.Free;
          ADIB.Free;
          ADIB:=nil;
          Exit;
        end;
    end; {Case}
    BFile.Free;
    Result:=UDIBNoError;
  except
    on EReadError do
      Result:=UDIBReadError
    else
      Result:=UDIBUndefError;
    ADIB.Free;
    ADIB:=nil;
    BFile.Free;
  end;
end;

initialization
  UpsideDownDIB:=False;
end.