bmpfilt.pas

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

(*
Copyright (c) 1998-2007 by HiComponents. All rights reserved.

This software comes without express or implied warranty.
In no case shall the author be liable for any damage or unwanted behavior of any
computer hardware and/or software.

HiComponents grants you the right to include the compiled component
in your application, whether COMMERCIAL, SHAREWARE, or FREEWARE,
BUT YOU MAY NOT DISTRIBUTE THIS SOURCE CODE OR ITS COMPILED .DCU IN ANY FORM.

ImageEn, IEvolution and ImageEn ActiveX may not be included in any commercial,
shareware or freeware libraries or components.

email: [e-mail]

http://www.hicomponents.com
*)

unit bmpfilt;

{$R-}
{$Q-}

{$I ie.inc}

interface

uses Windows, Graphics, classes, sysutils, ImageEnProc, ImageEnIO, hyiedefs, hyieutils;

// BMP
procedure BMPReadStream(fs: TStream; Bitmap: TIEBitmap; BlockDim: integer; var IOParams: TIOParamsVals; var Progress: TProgressRec; Preview: boolean; MissingFileHead: boolean; var AlphaChannel: TIEMask; IgnoreAlpha: boolean);
procedure BMPWriteStream(fs: TStream; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; var Progress: TProgressRec; Save32BitAsAlpha:boolean);

// Real RAW
procedure IERealRAWReadStream(fs:TStream; Bitmap:TIEBitmap; var IOParams:TIOParamsVals; var Progress:TProgressRec);
procedure IERealRAWWriteStream(fs:TStream; Bitmap:TIEBitmap; var IOParams:TIOParamsVals; var Progress:TProgressRec);

// ICO
function ICOTryStream(fs: TStream): boolean;
procedure ICOReadStream(fs: TStream; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; Preview: boolean; var Progress: TProgressRec; var AlphaChannel: TIEMask; IgnoreAlpha: boolean);
procedure ICOWriteStream(fs: TStream; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; var Progress: TProgressRec; sizes: array of TSize; bitcounts: array of integer);
procedure ICOWriteStream2(fs: TStream; ielist: array of TObject; var Progress: TProgressRec);
function _EnumICOImStream(fs: TStream): integer;

// CUR
function CURTryStream(fs: TStream): boolean;
procedure CURReadStream(fs: TStream; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; Preview: boolean; var Progress: TProgressRec; var AlphaChannel: TIEMask; IgnoreAlpha: boolean);

// PXM
procedure PXMReadStream(fs: TStream; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; var Progress: TProgressRec; Preview: boolean);
procedure PXMWriteStream(fs: TStream; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; var Progress: TProgressRec);
function TryPXM(fs: TStream): boolean;

// WBMP
procedure WBMPReadStream(fs: TStream; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; var Progress: TProgressRec; Preview: boolean);
procedure WBMPWriteStream(fs: TStream; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; var Progress: TProgressRec);

// PostScript (PS)
function IEPostScriptCreate(fs: TStream; var IOParams: TIOParamsVals): pointer;
procedure IEPostScriptClose(handle: pointer; fs: TStream);
procedure IEPostScriptSave(handle: pointer; fs: TStream; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; var Progress: TProgressRec);
procedure IEPostScriptSaveOneStep(fs: TStream; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; var Progress: TProgressRec);

// PDF
function IEPDFCreate(var IOParams: TIOParamsVals): pointer;
procedure IEPDFSave(handle: pointer; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; var Progress: TProgressRec);
procedure IEPDFClose(handle: pointer; fs: TStream; var IOParams: TIOParamsVals);
procedure IEPDFSaveOneStep(fs: TStream; Bitmap: TIEBitmap; var IOParams: TIOParamsVals; var Progress: TProgressRec);

// others
function IEWMFTryStream(Stream:TStream):boolean;
function IEEMFTryStream(Stream:TStream):boolean;

implementation

uses neurquant, imageenview, ieview, tifccitt, jpegfilt;

{$R-}

type
  // Bitmap infoheader + OS2 2.x extensions
  TBITMAPINFOHEADER2 = packed record
    biSize: DWORD;
    biWidth: Longint;
    biHeight: Longint;
    biPlanes: Word;
    biBitCount: Word;
    biCompression: DWORD;
    biSizeImage: DWORD;
    biXPelsPerMeter: Longint;
    biYPelsPerMeter: Longint;
    biClrUsed: DWORD;
    biClrImportant: DWORD;
    // os2 part
    biUnits: word;
    biReserved: word;
    biRecording: word;
    biRendering: word;
    biSize1: dword;
    biSize2: dword;
    biColorencoding: dword;
    biIdentifier: dword;
  end;

procedure DecompRLE4_to24(Bitmap: TIEBitmap; bits2: pbyte; xImageDim: integer; ColorMap: PRGBROW; var Progress: TProgressRec; inverter: integer);
var
  y, q, w, xx: integer;
  ww: integer;
  px: PRGB;
  procedure WriteLo;
  begin
    {$ifdef IEPROFILE} try IEProfileBegin('DecompRLE4_to24.WriteLo'); {$endif}
    if ww < Bitmap.Width then
    begin
      px^ := ColorMap^[bits2^ shr 4];
      inc(px);
      inc(ww);
    end;
    {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
  end;
  procedure WriteHi;
  begin
    {$ifdef IEPROFILE} try IEProfileBegin('DecompRLE4_to24.WriteHi'); {$endif}
    if ww < Bitmap.Width then
    begin
      px^ := ColorMap^[bits2^ and $0F];
      inc(px);
      inc(ww);
    end;
    {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
  end;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('DecompRLE4_to24'); {$endif}
  y := Bitmap.height - 1;
  px := Bitmap.scanline[abs(inverter - y)];
  q := 0;
  ww := 0;
  while q < xImageDim do
  begin
    if bits2^ = 0 then
    begin
      // escape
      inc(bits2);
      inc(q);
      case bits2^ of
        0:
          begin
            // eol
            dec(y);
            if y < 0 then
              break;
            w := imin(imax(0, abs(inverter - y)), Bitmap.Height - 1);
            px := Bitmap.scanline[w];
            ww := 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);
            inc(q);
            w := bits2^;
            inc(bits2);
            inc(q);
            dec(y, bits2^);
            px := Bitmap.scanline[abs(inverter - y)];
            inc(px, w);
          end;
      else
        begin
          // absolute packet
          xx := bits2^;
          for w := 0 to (xx shr 1) - 1 do
          begin
            inc(bits2);
            inc(q);
            WriteLo;
            WriteHi;
          end;
          if xx and 1 <> 0 then
          begin
            inc(bits2);
            inc(q);
            WriteLo;
          end;
          xx := (xx shr 1) + (xx and 1);
          if xx and 1 <> 0 then
          begin
            inc(bits2);
            inc(q);
          end;
        end;
      end;
      inc(bits2);
      inc(q);
    end
    else
    begin
      // run length
      xx := bits2^;
      inc(bits2);
      inc(q);
      for w := 0 to (xx shr 1) - 1 do
      begin
        WriteLo;
        WriteHi;
      end;
      if xx and 1 <> 0 then
        WriteLo;
      inc(bits2);
      inc(q);
    end;
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

procedure DecompRLE4_to8(Bitmap: TIEBitmap; bits2: pbyte; xImageDim: integer; ColorMap: PRGBROW; var Progress: TProgressRec; inverter: integer);
var
  y, q, w, xx: integer;
  px: pbyte;
  ww: integer;
  procedure WriteLo;
  begin
    {$ifdef IEPROFILE} try IEProfileBegin('DecompRLE4_to8.WriteLo'); {$endif}
    if ww < Bitmap.Width then
    begin
      px^ := bits2^ shr 4;
      inc(px);
      inc(ww);
    end;
    {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
  end;
  procedure WriteHi;
  begin
    {$ifdef IEPROFILE} try IEProfileBegin('DecompRLE4_to8.WriteHi'); {$endif}
    if ww < Bitmap.Width then
    begin
      px^ := bits2^ and $0F;
      inc(px);
      inc(ww);
    end;
    {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
  end;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('DecompRLE4_to8'); {$endif}
  y := Bitmap.height - 1;
  px := Bitmap.scanline[abs(inverter - y)];
  q := 0;
  ww := 0;
  while q < xImageDim do
  begin
    if bits2^ = 0 then
    begin
      // escape
      inc(bits2);
      inc(q);
      case bits2^ of
        0:
          begin
            // eol
            dec(y);
            if y < 0 then
              break;
            w := imin(imax(0, abs(inverter - y)), Bitmap.Height - 1);
            px := Bitmap.scanline[w];
            ww := 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(q);
            inc(bits2);
            dec(y, bits2^);
            inc(q);
            px := Bitmap.scanline[abs(inverter - y)];
            inc(px, w);
          end;
      else
        begin
          // absolute packet
          xx := bits2^;
          for w := 0 to (xx shr 1) - 1 do
          begin
            inc(bits2);
            inc(q);
            WriteLo;
            WriteHi;
          end;
          if xx and 1 <> 0 then
          begin
            inc(bits2);
            inc(q);
            WriteLo;
          end;
          xx := (xx shr 1) + (xx and 1);
          if xx and 1 <> 0 then
          begin
            inc(bits2);
            inc(q);
          end;
        end;
      end;
      inc(bits2);
      inc(q);
    end
    else
    begin
      // run length
      xx := bits2^;
      inc(bits2);
      inc(q);
      for w := 0 to (xx shr 1) - 1 do
      begin
        WriteLo;
        WriteHi;
      end;
      if xx and 1 <> 0 then
        WriteLo;
      inc(bits2);
      inc(q);
    end;
  end;
  {$ifdef IEPROFILE} finally IEProfileEnd; end; {$endif}
end;

///////////////////////////////////////////////////////////////////////

procedure DecompRLE8_to24(Bitmap: TIEBitmap; bits2: pbyte; xImageDim: integer; ColorMap: PRGBROW; var Progress: TProgressRec; inverter: integer);
var
  y, q, w, xx, x: integer;
  px: PRGB;
begin
  {$ifdef IEPROFILE} try IEProfileBegin('DecompRLE8_to24'); {$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