pngimage.pas

iocopm3.04源码,一套很好的工控开发工具

{Portable Network Graphics Delphi 1.4361   (8 March 2003)     }

{This is the latest implementation for TPngImage component    }
{It's meant to be a full replacement for the previous one.    }
{There are lots of new improvements, including cleaner code,  }
{full partial transparency support, speed improvements,       }
{saving using ADAM 7 interlacing, better error handling, also }
{the best compression for the final image ever. And now it's  }
{truly able to read about any png image.                      }

{
  Version 1.4361
  2003-03-04 - Fixed important bug for simple transparency when using
               RGB, Grayscale color modes

  Version 1.436
  2003-03-04 - * NEW * Property Pixels for direct access to pixels
               * IMPROVED * Palette property (TPngObject) (read only)
               Slovenian traslation for the component (Miha Petelin)
               Help file update (scanline article/png->jpg example)

  Version 1.435
  2003-11-03 - * NEW * New chunk implementation zTXt (method AddzTXt)
               * NEW * New compiler flags to store the extra 8 bits
               from 16 bits samples (when saving it is ignored), the
               extra data may be acessed using ExtraScanline property
               * Fixed * a bug on tIMe chunk
               French translation included (Thanks to IBE Software)
               Bugs fixed

  Version 1.432
  2002-08-24 - * NEW *  A new method, CreateAlpha will transform the
               current image into partial transparency.
               Help file updated with a new article on how to handle
               partial transparency.

  Version 1.431
  2002-08-14 - Fixed and tested to work on:
               C++ Builder 3
               C++ Builder 5
               Delphi 3
               There was an error when setting TransparentColor, fixed
               New method, RemoveTransparency to remove image
               BIT TRANSPARENCY

  Version 1.43
  2002-08-01 - * NEW * Support for Delphi 3 and C++ Builder 3
               Implements mostly some things that were missing,
               a few tweaks and fixes.

  Version 1.428
  2002-07-24 - More minor fixes (thanks to Ian Boyd)
               Bit transparency fixes
               * NEW * Finally support to bit transparency
               (palette / rgb / grayscale -> all)

  Version 1.427
  2002-07-19 - Lots of bugs and leaks fixed
               * NEW * method to easy adding text comments, AddtEXt
               * NEW * property for setting bit transparency,
                       TransparentColor

  Version 1.426
  2002-07-18 - Clipboard finally fixed (hope)
               Changed UseDelphi trigger to UseDelphi
               * NEW * Support for bit transparency bitmaps
                       when assigning from/to TBitmap objects
               Altough it does not support drawing transparent
               parts of bit transparency pngs (only partial)
               it is closer than ever

  Version 1.425
  2002-07-01 - Clipboard methods implemented
               Lots of bugs fixed

  Version 1.424
  2002-05-16 - Scanline and AlphaScanline are now working correctly.
               New methods for handling the clipboard

  Version 1.423
  2002-05-16 - * NEW * Partial transparency for 1, 2, 4 and 8 bits is
               also supported using the tRNS chunk (for palette and
               grayscaling).
               New bug fixes (Peter Haas).

  Version 1.422
  2002-05-14 - Fixed some critical leaks, thanks to Peter Haas tips.
               New translation for German (Peter Haas).

  Version 1.421
  2002-05-06 - Now uses new ZLIB version, 1.1.4 with some security
               fixes.
               LoadFromResourceID and LoadFromResourceName added and
               help file updated for that.
               The resources strings are now located in pnglang.pas.
               New translation for Brazilian Portuguese.
               Bugs fixed.

 IMPORTANT: I'm currently looking for bugs on the library. If
            anyone has found one, please send me an email and
            I will fix right away. Thanks for all the help and
            ideias I'm receiving so far.}

{My new email is: [e-mail]}
{Website link   : pngdelphi.sourceforge.net}
{Gustavo Huffenbacher Daud}

unit pngimage;

interface

{Triggers avaliable (edit the fields bellow)}
{$DEFINE UseDelphi}              //Disable fat vcl units (perfect to small apps)
{$DEFINE ErrorOnUnknownCritical} //Error when finds an unknown critical chunk
{$DEFINE CheckCRC}               //Enables CRC checking
{$DEFINE RegisterGraphic}        //Registers TPNGObject to use with TPicture
{$DEFINE PartialTransparentDraw} //Draws partial transparent images
{.$DEFINE Store16bits}            //Stores the extra 8 bits from 16bits/sample
{.$DEFINE Debug}                 //For programming purposes
{$RANGECHECKS OFF} {$J+}



uses
 Windows {$IFDEF UseDelphi}, Classes, Graphics, SysUtils{$ENDIF} {$IFDEF Debug},
 dialogs{$ENDIF}, pngzlib, pnglang;

{$IFNDEF UseDelphi}
  const
    soFromBeginning = 0;
    soFromCurrent = 1;
    soFromEnd = 2;
{$ENDIF}

const
  {ZLIB constants}
  ZLIBErrors: Array[-6..2] of string = ('incompatible version (-6)',
    'buffer error (-5)', 'insufficient memory (-4)', 'data error (-3)',
    'stream error (-2)', 'file error (-1)', '(0)', 'stream end (1)',
    'need dictionary (2)');
  Z_NO_FLUSH      = 0;
  Z_FINISH        = 4;
  Z_STREAM_END    = 1;

  {Avaliable PNG filters for mode 0}
  FILTER_NONE    = 0;
  FILTER_SUB     = 1;
  FILTER_UP      = 2;
  FILTER_AVERAGE = 3;
  FILTER_PAETH   = 4;

  {Avaliable color modes for PNG}
  COLOR_GRAYSCALE      = 0;
  COLOR_RGB            = 2;
  COLOR_PALETTE        = 3;
  COLOR_GRAYSCALEALPHA = 4;
  COLOR_RGBALPHA       = 6;


type
  {$IFNDEF UseDelphi}
    {Custom exception handler}
    Exception = class(TObject)
      constructor Create(Msg: String);
    end;
    ExceptClass = class of Exception;
    TColor = ColorRef;
  {$ENDIF}

  {Error types}
  EPNGOutMemory = class(Exception);
  EPngError = class(Exception);
  EPngUnexpectedEnd = class(Exception);
  EPngInvalidCRC = class(Exception);
  EPngInvalidIHDR = class(Exception);
  EPNGMissingMultipleIDAT = class(Exception);
  EPNGZLIBError = class(Exception);
  EPNGInvalidPalette = class(Exception);
  EPNGInvalidFileHeader = class(Exception);
  EPNGIHDRNotFirst = class(Exception);
  EPNGNotExists = class(Exception);
  EPNGSizeExceeds = class(Exception);
  EPNGMissingPalette = class(Exception);
  EPNGUnknownCriticalChunk = class(Exception);
  EPNGUnknownCompression = class(Exception);
  EPNGUnknownInterlace = class(Exception);
  EPNGNoImageData = class(Exception);
  EPNGCouldNotLoadResource = class(Exception);
  EPNGCannotChangeTransparent = class(Exception);
  EPNGHeaderNotPresent = class(Exception);

type
  {Direct access to pixels using R,G,B}
  TRGBLine = array[word] of TRGBTriple;
  pRGBLine = ^TRGBLine;

  {Same as TBitmapInfo but with allocated space for}
  {palette entries}
  TMAXBITMAPINFO = packed record
    bmiHeader: TBitmapInfoHeader;
    bmiColors: packed array[0..255] of TRGBQuad;
  end;

  {Transparency mode for pngs}
  TPNGTransparencyMode = (ptmNone, ptmBit, ptmPartial);
  {Pointer to a cardinal type}
  pCardinal = ^Cardinal;
  {Access to a rgb pixel}
  pRGBPixel = ^TRGBPixel;
  TRGBPixel = packed record
    B, G, R: Byte;
  end;

  {Pointer to an array of bytes type}
  TByteArray = Array[Word] of Byte;
  pByteArray = ^TByteArray;

  {Forward}
  TPNGObject = class;
  pPointerArray = ^TPointerArray;
  TPointerArray = Array[Word] of Pointer;

  {Contains a list of objects}
  TPNGPointerList = class
  private
    fOwner: TPNGObject;
    fCount : Cardinal;
    fMemory: pPointerArray;
    function GetItem(Index: Cardinal): Pointer;
    procedure SetItem(Index: Cardinal; const Value: Pointer);
  protected
    {Removes an item}
    function Remove(Value: Pointer): Pointer; virtual;
    {Inserts an item}
    procedure Insert(Value: Pointer; Position: Cardinal);
    {Add a new item}
    procedure Add(Value: Pointer);
    {Returns an item}
    property Item[Index: Cardinal]: Pointer read GetItem write SetItem;
    {Set the size of the list}
    procedure SetSize(const Size: Cardinal);
    {Returns owner}
    property Owner: TPNGObject read fOwner;
  public
    {Returns number of items}
    property Count: Cardinal read fCount write SetSize;
    {Object being either created or destroyed}
    constructor Create(AOwner: TPNGObject);
    destructor Destroy; override;
  end;

  {Forward declaration}
  TChunk = class;
  TChunkClass = class of TChunk;

  {Same as TPNGPointerList but providing typecasted values}
  TPNGList = class(TPNGPointerList)
  private
    {Used with property Item}
    function GetItem(Index: Cardinal): TChunk;
  public
    {Removes an item}
    procedure RemoveChunk(Chunk: TChunk); overload;
    {Add a new chunk using the class from the parameter}
    function Add(ChunkClass: TChunkClass): TChunk;
    {Returns pointer to the first chunk of class}
    function ItemFromClass(ChunkClass: TChunkClass): TChunk;
    {Returns a chunk item from the list}
    property Item[Index: Cardinal]: TChunk read GetItem;
  end;

  {$IFNDEF UseDelphi}
    {The STREAMs bellow are only needed in case delphi provided ones is not}
    {avaliable (UseDelphi trigger not set)}
    {Object becomes handles}
    TCanvas = THandle;
    TBitmap = HBitmap;
    {Trick to work}
    TPersistent = TObject;

    {Base class for all streams}
    TStream = class
    protected
      {Returning/setting size}
      function GetSize: Longint; virtual;
      procedure SetSize(const Value: Longint); virtual; abstract;
      {Returns/set position}
      function GetPosition: Longint; virtual;
      procedure SetPosition(const Value: Longint); virtual;
    public
      {Returns/sets current position}
      property Position: Longint read GetPosition write SetPosition;
      {Property returns/sets size}
      property Size: Longint read GetSize write SetSize;
      {Allows reading/writing data}
      function Read(var Buffer; Count: Longint): Cardinal; virtual; abstract;
      function Write(const Buffer; Count: Longint): Cardinal; virtual; abstract;
      {Copies from another Stream}
      function CopyFrom(Source: TStream;
        Count: Cardinal): Cardinal; virtual;
      {Seeks a stream position}
      function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;
    end;

    {File stream modes}
    TFileStreamMode = (fsmRead, fsmWrite, fsmCreate);
    TFileStreamModeSet = set of TFileStreamMode;

    {File stream for reading from files}
    TFileStream = class(TStream)
    private
      {Opened mode}
      Filemode: TFileStreamModeSet;
      {Handle}
      fHandle: THandle;
    protected
      {Set the size of the file}
      procedure SetSize(const Value: Longint); override;
    public
      {Seeks a file position}
      function Seek(Offset: Longint; Origin: Word): Longint; override;
      {Reads/writes data from/to the file}
      function Read(var Buffer; Count: Longint): Cardinal; override;
      function Write(const Buffer; Count: Longint): Cardinal; override;
      {Stream being created and destroy}
      constructor Create(Filename: String; Mode: TFileStreamModeSet);
      destructor Destroy; override;
    end;

    {Stream for reading from resources}
    TResourceStream = class(TStream)
      constructor Create(Instance: HInst; const ResName: String; ResType:PChar);
    private
      {Variables for reading}
      Size: Integer;
      Memory: Pointer;
      Position: Integer;
    protected
      {Set the size of the file}
      procedure SetSize(const Value: Longint); override;
    public
      {Stream processing}
      function Read(var Buffer; Count: Integer): Cardinal; override;
      function Seek(Offset: Integer; Origin: Word): Longint; override;
      function Write(const Buffer; Count: Longint): Cardinal; override;
    end;
  {$ENDIF}

  {Forward}
  TChunkIHDR = class;
  {Interlace method}
  TInterlaceMethod = (imNone, imAdam7);
  {Compression level type}
  TCompressionLevel = 0..9;
  {Filters type}
  TFilter = (pfNone, pfSub, pfUp, pfAverage, pfPaeth);
  TFilters = set of TFilter;

  {Png implementation object}
  TPngObject = class{$IFDEF UseDelphi}(TGraphic){$ENDIF}
  protected
    {Gamma table values}
    GammaTable, InverseGamma: Array[Byte] of Byte;
    procedure InitializeGamma;
  private
    {Temporary palette}
    TempPalette: HPalette;
    {Filters to test to encode}
    fFilters: TFilters;
    {Compression level for ZLIB}
    fCompressionLevel: TCompressionLevel;
    {Maximum size for IDAT chunks}
    fMaxIdatSize: Cardinal;
    {Returns if image is interlaced}
    fInterlaceMethod: TInterlaceMethod;
    {Chunks object}
    fChunkList: TPngList;
    {Clear all chunks in the list}
    procedure ClearChunks;
    {Returns if header is present}
    function HeaderPresent: Boolean;
    {Returns linesize and byte offset for pixels}
    procedure GetPixelInfo(var LineSize, Offset: Cardinal);
    procedure SetMaxIdatSize(const Value: Cardinal);
    function GetAlphaScanline(const LineIndex: Integer): pByteArray;
    function GetScanline(const LineIndex: Integer): Pointer;
    {$IFDEF Store16bits}
    function GetExtraScanline(const LineIndex: Integer): Pointer;
    {$ENDIF}
    function GetTransparencyMode: TPNGTransparencyMode;
    function GetTransparentColor: TColor;
    procedure SetTransparentColor(const Value: TColor);
  protected
    {Returns the image palette}
    function GetPalette: HPALETTE; {$IFDEF UseDelphi}override;{$ENDIF}
    {Returns/sets image width and height}
    function GetWidth: Integer; {$IFDEF UseDelphi}override;{$ENDIF}
    function GetHeight: Integer; {$IFDEF UseDelphi}override; {$ENDIF}
    procedure SetWidth(Value: Integer);  {$IFDEF UseDelphi}override; {$ENDIF}
    procedure SetHeight(Value: Integer);  {$IFDEF UseDelphi}override;{$ENDIF}
    {Assigns from another TPNGObject}
    procedure AssignPNG(Source: TPNGObject);
    {Returns if the image is empty}
    function GetEmpty: Boolean; {$IFDEF UseDelphi}override; {$ENDIF}
    {Used with property Header}
    function GetHeader: TChunkIHDR;