bmpfilt.pas

·ImageEn 2.3.0 ImageEn一组用于图像处理、查看和分析的Delphi控件。能够保存几种图像格式

              break;
          end;
        1: break; // eof
        2:
          begin
            // delta
            inc(bits2);
            w := bits2^;
            inc(bits2);
            dec(y, bits2^);
            px := Bitmap.scanline[abs(inverter - y)];
            inc(x, w);
            if x < Bitmap.Width then
              inc(px, w);
          end;
      else
        begin
          // packet
          xx := bits2^ - 1;
          for w := 0 to xx do
          begin
            inc(bits2);
            px^ := ColorMap^[bits2^];
            inc(x);
            if x < Bitmap.Width then
              inc(px);
          end;
          if xx and 1 = 0 then
            inc(bits2);
        end;
      end;
      inc(bits2);
    end
    else
    begin
      // run length
      xx := bits2^ - 1;
      inc(bits2);
      for w := 0 to xx do
      begin
        px^ := ColorMap^[bits2^];
        inc(x);
        if x < Bitmap.Width then
          inc(px);
      end;
      inc(bits2);
    end;
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

procedure DecompRLE8_to8(Bitmap: TIEBitmap; bits2: pbyte; xImageDim: integer; ColorMap: PRGBROW; var Progress: TProgressRec; inverter: integer);
var
  y, q, w, xx, x: integer;
  px: pbyte;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('DecompRLE8_to8'); {$endif}
  y := Bitmap.height - 1; // vertical position (inverted)
  px := Bitmap.scanline[abs(inverter - y)];
  x := 0; // horizontal position
  for q := 0 to xImageDim - 1 do
  begin
    if bits2^ = 0 then
    begin
      // escape
      inc(bits2);
      case bits2^ of
        0:
          begin
            // eol
            dec(y);
            if y < 0 then
              break;
            px := Bitmap.scanline[abs(inverter - y)];
            x := 0;
            // OnProgress
            with Progress do
              if assigned(fOnProgress) then
                fOnProgress(Sender, trunc(per1 * (Bitmap.height - y)));
            if Progress.Aborting^ then
              break;
          end;
        1: break; // eof
        2:
          begin
            // delta
            inc(bits2);
            w := bits2^;
            inc(bits2);
            dec(y, bits2^);
            px := Bitmap.scanline[abs(inverter - y)];
            inc(x, w);
            if x < Bitmap.Width then
              inc(px, w);
          end;
      else
        begin
          // packet
          xx := bits2^ - 1;
          for w := 0 to xx do
          begin
            inc(bits2);
            px^ := bits2^;
            inc(x);
            if x < Bitmap.Width then
              inc(px);
          end;
          if xx and 1 = 0 then
            inc(bits2);
        end;
      end;
      inc(bits2);
    end
    else
    begin
      // run length
      xx := bits2^ - 1;
      inc(bits2);
      for w := 0 to xx do
      begin
        px^ := bits2^;
        inc(x);
        if x < Bitmap.Width then
          inc(px);
      end;
      inc(bits2);
    end;
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

type
  TColorMap4 = array[0..255] of TRGBQUAD;

procedure BMPReadStream(fs: TStream; Bitmap: TIEBitmap; BlockDim: integer; var IOParams: TIOParamsVals; var Progress: TProgressRec; Preview: boolean; MissingFileHead: boolean; var AlphaChannel: TIEMask; IgnoreAlpha: boolean);
var
  FileHead: TBITMAPFILEHEADER;
  InfoHead: ^TBITMAPINFOHEADER2;
  CoreHead: ^TBITMAPCOREHEADER;
  dm: integer; // size of structure next to BITMAPFILEHEADER
  p0: int64;
  xBitCount: integer;
  xCompression: integer;
  xImageDim: integer; // image size (can be 0 for non compressed images)
  ColorMap4: ^TColorMap4;
  BitFields: array[0..2] of dword;
  q, w, x, y: integer;
  lw: integer;
  px: PRGB;
  px_byte, bits, bits2: pbyte;
  gbitcount, rbitcount, bbitcount: integer;
  rshift, gshift, bshift: integer;
  wbits: pword;
  bitmapwidth1, bitmapheight1, inverter: integer;
  pf: TIEPixelFormat;
  allzeroalpha:boolean;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('BMPReadStream'); {$endif}
{$WARNINGS OFF}
  getmem(ColorMap4, 256 * sizeof(TRGBQUAD));
  getmem(InfoHead, sizeof(TBITMAPINFOHEADER2));
  getmem(CoreHead, sizeof(TBITMAPCOREHEADER));
  try
    xImageDim := 0;
    p0 := fs.Position;
    if MissingFileHead then
    begin
      FileHead.bfType := 19778;
      FileHead.bfSize := fs.Size;
      FileHead.bfReserved1 := 0;
      FileHead.bfReserved2 := 0;
      FileHead.bfOffBits := 0;
    end
    else
      fs.Read(FileHead, sizeof(TBITMAPFILEHEADER));
    if (FileHead.bfSize > 0) and (BlockDim <= 0) then
      BlockDim := FileHead.bfSize;
    if FileHead.bfType <> 19778 then
    begin
      Progress.Aborting^ := true;
      exit;
    end;
    fs.Read(dm, sizeof(dm)); // read size of next header
    fs.seek(-4, soFromCurrent);
    // if present remove old colormap
    if IOParams.ColorMap <> nil then
    begin
      freemem(IOParams.ColorMap);
      IOParams.fColorMap := nil;
      IOParams.fColorMapCount := 0;
    end;
    // read headers
    if dm = sizeof(TBITMAPCOREHEADER) then
    begin
      // read BITMAPCOREHEADER (OS2 v1.x)
      fs.Read(CoreHead^, dm);
      IOParams.BMP_Version := ioBMP_BMOS2V1;
      if InfoHead^.biHeight < 0 then
      begin
        InfoHead^.biHeight := -InfoHead^.biHeight;
        inverter := InfoHead^.biHeight - 1;
      end
      else
        inverter := 0;
      IOParams.Width := CoreHead^.bcWidth;
      IOParams.Height := CoreHead^.bcHeight;
      xBitCount := CoreHead^.bcBitCount;
      xCompression := BI_RGB;
      IOParams.DpiX := gDefaultDPIX;
      IOParams.DpiY := gDefaultDPIY;
      // read colormap
      if xBitCount <= 8 then
      begin
        w := 1 shl xBitCount;
        IOParams.fColorMapCount := w;
        IOParams.fColorMap := allocmem(w * sizeof(TRGB));
        fs.Read(IOParams.ColorMap^, w * sizeof(TRGB));
      end;
    end
    else
    begin
      // read BITMAPINFOHEADER
      FillChar(InfoHead^, sizeof(TBITMAPINFOHEADER2), 0);
      fs.Read(InfoHead^, imin(sizeof(TBITMAPINFOHEADER2), dm));
      if dm > sizeof(TBITMAPINFOHEADER2) then
        fs.seek(dm - 40, soFromCurrent); // bypass extra data
      if dm = 64 then
        IOParams.BMP_Version := ioBMP_BMOS2V2
      else if dm = 40 then
        IOParams.BMP_Version := ioBMP_BM3
      else
        IOParams.BMP_Version := ioBMP_BM;
      if InfoHead^.biHeight < 0 then
      begin
        InfoHead^.biHeight := -InfoHead^.biHeight;
        inverter := InfoHead^.biHeight - 1;
      end
      else
        inverter := 0;
      IOParams.Width := InfoHead^.biWidth;
      IOParams.Height := InfoHead^.biHeight;
      xBitCount := InfoHead^.biBitCount;
      xCompression := InfoHead^.biCompression;
      xImageDim := InfoHead^.biSizeImage;
      IOParams.DpiX := round((InfoHead^.biXPelsPerMeter / 100) * 2.54);
      if IOParams.DpiX = 0 then
        IOParams.DpiX := gDefaultDPIX;
      IOParams.DpiY := round((InfoHead^.biYPelsPerMeter / 100) * 2.54);
      if IOParams.DpiY = 0 then
        IOParams.DpiY := gDefaultDPIY;
      // read colormap
      if InfoHead^.biClrUsed > 256 then
        InfoHead^.biClrUsed := 0;
      if (InfoHead^.biClrUsed = 0) and (xBitCount <= 8) then
        InfoHead^.biClrUsed := 1 shl xBitCount; // default
      if (InfoHead^.biClrUsed > 0) then
      begin
        fs.Read(ColorMap4^, InfoHead^.biClrUsed * sizeof(TRGBQUAD));
        IOParams.fColorMapCount := InfoHead^.biClrUsed;
        IOParams.fColorMap := allocmem(InfoHead^.biClrUsed * sizeof(TRGB));
        for q := 0 to InfoHead^.biClrUsed - 1 do
        begin
          IOParams.ColorMap[q].r := ColorMap4^[q].rgbRed;
          IOParams.ColorMap[q].g := ColorMap4^[q].rgbGreen;
          IOParams.ColorMap[q].b := ColorMap4^[q].rgbBlue;
        end;
      end;
      // read bitfields
      if xCompression = BI_BITFIELDS then
        fs.Read(BitFields, 12);
    end;
    if (xCompression = BI_RGB) or (xCompression = BI_BITFIELDS) then
      IOParams.BMP_Compression := ioBMP_UNCOMPRESSED;
    if (xCompression = BI_RLE4) or (xCompression = BI_RLE8) then
      IOParams.BMP_Compression := ioBMP_RLE;
    // read bitmap
    if FileHead.bfOffBits > 0 then
      fs.Position := p0 + FileHead.bfOffBits; // go to bitmap start
    if BlockDim > 0 then
      xImageDim := BlockDim - (fs.position - p0);
    if (IOParams.Width = 0) or (IOParams.Height = 0) then
      Preview := true;
    if not Preview then
    begin
      if xBitCount = 1 then
        pf := ie1g
      else if (xBitCount = 4) and IOParams.IsNativePixelFormat then
        pf := ie8p
      else if (xBitCount = 8) and IOParams.IsNativePixelFormat then
        pf := ie8p
      else
        pf := ie24RGB;
      Bitmap.Allocate(IOParams.Width, IOParams.Height, pf);
      Progress.per1 := 100 / Bitmap.Height;
      lw := (((Bitmap.Width * xBitCount) + 31) shr 5) shl 2; // row byte length
    end
    else
      lw := 0; // prevents warnings
    case xBitCount of
      1:
        begin // 1 bit per pixel
          IOParams.BitsPerSample := 1;
          IOParams.SamplesPerPixel := 1;
          if not Preview then
          begin
            if xCompression = BI_RGB then
            begin
              bitmapheight1 := Bitmap.Height - 1;
              for y := BitmapHeight1 downto 0 do
              begin
                // OnProgress
                with Progress do
                  if assigned(fOnProgress) then
                    fOnProgress(Sender, trunc(per1 * (BitmapHeight1 - y)));
                if Progress.Aborting^ then
                  break;
                fs.read(pbyte(Bitmap.Scanline[abs(inverter - y)])^, lw);
              end;
              if (IOParams.fColorMapCount = 2) and
                equalrgb(IOParams.fColorMap^[0], creatergb(255, 255, 255)) and
                equalrgb(IOParams.fColorMap^[1], creatergb(0, 0, 0)) then
                _Negative1BitEx(Bitmap);
            end;
          end; // endif not preview
        end;
      4:
        begin // 4 bit per pixel
          IOParams.BitsPerSample := 4;
          IOParams.SamplesPerPixel := 1;
          if not Preview then
          begin
            if IOParams.IsNativePixelFormat then
              // set color map
              for y := 0 to IOParams.ColorMapCount - 1 do
                Bitmap.Palette[y] := IOParams.ColorMap[y];
            if xCompression = BI_RGB then
            begin
              getmem(bits, lw + 32);
              bitmapheight1 := Bitmap.Height - 1;
              bitmapwidth1 := Bitmap.Width - 1;
              for y := bitmapheight1 downto 0 do
              begin
                // OnProgress
                with Progress do
                  if assigned(fOnProgress) then
                    fOnProgress(Sender, trunc(per1 * (BitmapHeight1 - y)));
                if Progress.Aborting^ then
                  break;
                fs.Read(bits^, lw);
                bits2 := bits;
                if IOParams.IsNativePixelFormat then
                begin
                  // native format
                  Bitmap.PaletteUsed := 16;
                  px_byte := Bitmap.Scanline[abs(inverter - y)];
                  for x := 0 to bitmapwidth1 do
                  begin
                    if (x and 1) = 0 then
                      px_byte^ := bits2^ shr 4
                    else
                    begin
                      px_byte^ := bits2^ and $0F;
                      inc(bits2);
                    end;
                    inc(px_byte);
                  end;
                end
                else
                begin
                  // 4 bit to 24 bit
                  px := Bitmap.Scanline[abs(inverter - y)];
                  for x := 0 to bitmapwidth1 do