pngimage1.pas

查看html文件的控件

{Version 9.4}
{***************************************************************}
{*                    PNGImage1.PAS                             *}
{*                                                             *}
{*   Thanks to Gustavo Daud for this Pascal implementation     *}
{*   for PNG Images.                                           *}
{*                                                             *}
{*   Thanks also to Paul TOTH for his Delphi 3 Adaptation      *}
{*                                                             *}
{***************************************************************}

{*******************************************************}
{                                                       }
{       Portable Network Graphics decoder               }
{       * decode & encode png files in delphi *         }
{                                                       }
{       EMAIL: [e-mail]                   }
{                                                       }
{*******************************************************}

{ Delphi 3 compatibility and french translation by Paul TOTH <[e-mail]>}

{$i htmlcons.inc}

unit PngImage1;

{$R-}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;


//Supporting code for versions prior 5
{$IFDEF VER125} {$DEFINE PRIORDELPHI5} {$ENDIF}
{$IFDEF VER120} {$DEFINE PRIORDELPHI5} {$ENDIF}
{$IFDEF VER110} {$DEFINE PRIORDELPHI5} {$DEFINE PRIORDELPHI3} {$ENDIF}
{$IFDEF VER100} {$DEFINE PRIORDELPHI5} {$DEFINE PRIORDELPHI3} {$ENDIF}
{$IFDEF VER93}  {$DEFINE PRIORDELPHI5} {$DEFINE PRIORDELPHI3} {$ENDIF}
{$IFDEF VER80}  {$DEFINE PRIORDELPHI5} {$DEFINE PRIORDELPHI3} {$ENDIF}

resourcestring
  {.$INCLUDE Portuguese.TXT}
  {$INCLUDE English.TXT}
  {. $INCLUDE French.TXT}

{Portable Network Graphics implementation}
type
  {Encoding filter}
  TFilterRow = array[0..4] of PByteArray;
  TEncodeFilter = (efNone, efSub, efUp, efAverage, efPaeth);
  TEncodeFilterSet = set of TEncodeFilter;

  {:Chunk type}
  TChunkType = Array[0..3] of char;

  {Forward declarations}
  TPNGImage = class;
  TChunkList = class;
  TChunkGAMA = class;
  TChunkIHDR = class;

  {:This class handles the chunks}
  TChunk = class
    constructor Create(AOwner: TChunkList); virtual;
    destructor Destroy; override;
  private
    fList  : TChunkList;
    fStream: TMemoryStream;

    function GetSize: Integer;

    {Returns pointer to the most common chunk types}
    function GetIHDR   : TChunkIHDR;
    function GetGAMA   : TChunkGAMA;
    {Return a pointer to the TPNGImage owner}
    function GetBitmap : TPNGImage;

  protected
    fType  : TChunkType;
    function GetIndex: Integer;
    procedure DoAction; virtual;

    property IHDR  : TChunkIHDR read GetIHDR;
    property GAMA  : TChunkGAMA read GetGama;
    property Bitmap: TPNGImage  read GetBitmap;
    property Stream: TMemoryStream read fStream;
  public
    procedure Assign(Source: TChunk); virtual;
    procedure SaveToStream(Stream: TStream); virtual;
    property Index: Integer read GetIndex;
    property Owner: TChunkList read fList;
    property Size: Integer read GetSize;
    (*property ChunkType: TChunkType read fType;*) //LDB will not compile in C++Builder
  end;


  {:IEND Chunk, 0 bytes length}
  TChunkIEND = class(TChunk);

  {:tEXt Chunk, dynamic size, minimum 2 bytes (null separators)}
  TChunkTEXT = Class(TChunk)
    constructor Create(AOwner: TChunkList); override;
  private
    function GetValue(Index: Integer): String;
    procedure SetValue(Index: Integer; Value: String);
  public
    property Keyword: String index 0 read GetValue write SetValue;
    property Text: String index 1 read GetValue write SetValue;
  end;

  {:zTXt Chunk, dynamic size}
  TChunkZTXT = Class(TChunk)
  private
    function GetValue(Index: Integer): String;
    procedure SetValue(Index: Integer; Value: String);
  public
    property Keyword: String index 0 read GetValue write SetValue;
    property Text: String index 1 read GetValue write SetValue;
  end;

  {:gAMA Chunk, 4 bytes length}
  TChunkGAMA = class(TChunk)
    constructor Create(AOwner: TChunkList); override;
    procedure Assign(Source: TChunk); override;
  protected
    GammaTable,
    InverseTable: Array[Byte] of Byte;
    procedure DoAction; override;
  private
    function GetValue: Cardinal;
    procedure SetValue(Value: Cardinal);
  public
    property Value: Cardinal read GetValue write SetValue;
  end;

  {:PLTE Chunk, dynamic length}
  TChunkPLTE = class(TChunk)
    destructor Destroy; Override;
  private
    fPalette: HPalette;
    function GetPalette: HPalette;
  public
    procedure SaveToStream(Stream: TStream); override;
    property Palette: HPalette read GetPalette;
  end;

  {:IHDR Chunk, 13 bytes length}
  TChunkIHDR = class(TChunk)
    procedure SaveToStream(Stream: TStream); override;
    constructor Create(AOwner: TChunkList); override;
  private
    function GetWidth: Cardinal;
    function GetHeight: Cardinal;
    procedure SetWidth(Value: Cardinal);
    procedure SetHeight(Value: Cardinal);
    function GetValue(Index: Integer): Byte;
    procedure SetValue(Index: Integer; Value: Byte);
  public
    property Width: Cardinal read GetWidth write SetWidth;
    property Height: Cardinal read GetHeight write SetHeight;
    property BitDepth: Byte index 0 read GetValue write SetValue;
    property ColorType: Byte index 1 read GetValue write SetValue;
    property Compression: Byte index 2 read GetValue write SetValue;
    property Filter: Byte index 3 read GetValue write SetValue;
    property Interlaced: Byte index 4 read GetValue write SetValue;
  end;

  {:IDAT Chunk, dynamic size}
  TChunkIDAT = class(TChunk)
  public
    procedure SaveToStream(Stream: TStream); override;
  protected
    function GetBufferWidth: Integer;
    procedure FilterRow(Filter: Byte; CurrentRow, LastRow: pbytearray;
     offset, row_buffer_width: Integer);
    function EncodeFilterRow(row_buffer: pbytearray;
      Filter_buffers: TFilterRow; row_width, filter_width: Cardinal): Integer;
    procedure DoAction; override;
    function GetOffset: Integer;
    procedure EncodeImage;
    procedure SetupPixelFormat;
    procedure DecodeNonInterlacedRow(ImageData: Pointer; Data: pByteArray;
      RowBytes: Integer; GamaChunk: TChunkGama);
    procedure DecodeInterlacedRow(ImageData: Pointer; Data: pByteArray;
      ColStart, ColIncrement, RowBytes, Pass: Integer; GamaChunk: TChunkGama);
  end;

  {:tIME Chunk, 7 bytes}
  TChunkTIME = class(TChunk)
    constructor Create(AOwner: TChunkList); override;
    function GetDateTime: TDateTime;
  private
    procedure SetDateTime(const Value: TDateTime);
  public
    property DateTime: TDateTime read GetDateTime write SetDateTime;
  end;

  {:tRNS Chunk, dynamic length}
  TChunkTRNS = class(TChunk)
  private
    function GetRGBColor: TColor;
  public
    procedure SaveToStream(Stream: TStream); override;
    property RGBColor: TColor read GetRGBColor;
  end;


  {:Chunk class handler}
  TChunkClass = Class of TChunk;

  {:Record containg a chunk class info}
  pChunkClassInfo = ^TChunkClassInfo;
  TChunkClassInfo = record
    ChunkType:  TChunkType;
    ChunkClass: TChunkClass;
  end;

  {:This class contains the avaliable kinds of TChunk class}
  TChunkClasses = class
    destructor Destroy; Override;
  private
    fList: TList;
    function GetCount: Integer;
    function GetItem(Index: Integer): TChunkClassInfo;
  public
    property Count: Integer read GetCount;
    function IndexOfType(Item: TChunkType): Integer; { Paul - overload; }
    function IndexOfClass(Item: TChunkClass): Integer; { Paul - overload; }
    procedure Add(ChunkType: TChunkType; ChunkClass: TChunkClass);
    property Item[Index: Integer]: TChunkClassInfo read GetItem; default;
  end;

  {:This class contains the list of avaliable chunks for a TPNGImage }
  {:object class.                                                    }
  TChunkList = class
    constructor Create(AOwner: TPNGImage);
    destructor Destroy; override;
  private
    fImage: TPNGImage;
    fList : TList;
    function GetCount: Integer;
    function GetItem(Index: Integer): TChunk;
  public
    property Owner: TPNGImage read fImage;
    property Count: Integer read GetCount;
    property Item[Index: Integer]: TChunk read GetItem; default;
    procedure Move(Index1, Index2: Integer);
    function AddItem(Item: TChunk): TChunk; { Paul - overload; }
    function AddClass(ChunkClass: TChunkClass): TChunk; { Paul - overload; }
    function AddStream(Stream: TStream): TChunk; { Paul - overload; }
    procedure Remove(Item: TChunk);
    function IndexOfChunk(Chunk: TChunk): Integer; { Paul - overload; }
    function IndexOfClass(ChunkClass: TChunkClass): Integer; { Paul - overload; }
    procedure Clear;
  end;

  {:This format handler is able to load and save booth interlaced and
    non interlaced Portable Network Graphics images using a ZLIB
    compression decoder}
  TPNGImage = class(TBitmap)
    constructor Create; override;
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
  private
    fMask: TBitmap;
    fEncodeFilter: TEncodeFilterSet;
    fInterlacing: Boolean;
    fChunkList: TChunkList;
    procedure SetFilter(Value: TEncodeFilterSet);
  public
    procedure Assign(Source: TPersistent); override;
    property Filter: TEncodeFilterSet read fEncodeFilter write SetFilter;
    property Interlacing: Boolean read fInterlacing write fInterlacing;
    procedure Clear;
    property Chunks: TChunkList read fChunkList;
    class procedure RegisterChunkClass(ChunkType: TChunkType;
      ChunkClass: TChunkClass);
  end;

implementation

uses
  PNGZLIB1, Math;

{ Delphi versions prior 4 missing code}
{$IFDEF PRIORDELPHI5}
Procedure ReplaceTime(Var D:TDateTime; T:TDateTime);
 begin
  D:=D+T; // this work for PNGImage only !
 end;
{$ENDIF}

{ Delphi versions prior 3 missing code}
{$IFDEF PRIORDELPHI3}
Procedure ShowMessageFmt(msg:string; fmt:array of const);
 begin
  ShowMessage(Format(msg,fmt));
 end;
{$ENDIF}

var
  {Stores the avaliable kinds of TChunk}
  ChunkClasses: TChunkClasses;

const
  FILTERBUFFERCOUNT = 5;

  {Interlacing}
  RowStart: array[0..6] of Integer = (0, 0, 4, 0, 2, 0, 1);
  ColumnStart: array[0..6] of Integer = (0, 4, 0, 2, 0, 1, 0);
  RowIncrement: array[0..6] of Integer = (8, 8, 8, 4, 4, 2, 2);
  ColumnIncrement: array[0..6] of Integer = (8, 8, 4, 4, 2, 2, 1);
  PassMask: array[0..6] of Byte = ($80, $08, $88, $22, $AA, $55, $FF);

  {Color types}
  Grayscale = 0;
  RGB = 2;
  Palette = 3;
  GrayscaleAlpha = 4;
  RGBAlpha = 6;

  {Filter types}
  FILTERNONE = 0;
  FILTERSUB = 1;
  FILTERUP = 2;
  FILTERAVERAGE = 3;
  FILTERPAETH = 4;

  {Valid PNG header (first 8 bytes)}
  PNGHeader: array[0..7] of Byte = (137, 80, 78, 71, 13, 10, 26, 10);

type
  pCardinal = ^Cardinal;

  {Default error handler for PNG format}
  EPNGImageException = Class(Exception);

  {:IHDR Chunk}
  pIHDRChunk = ^TIHDRChunk;
  TIHDRChunk = packed record
    {Width and height give the image dimensions in pixels}
    Width, Height: Cardinal;
    {Bit depth is a single-byte integer giving the number of bits }
    {per sample or per palette index (not per pixel). Valid values}
    {are 1, 2, 4, 8, and 16, although not all values are allowed  }
    {for all color types                                          }
    BitDepth,
    {Color type is a single-byte integer that describes the }
    {interpretation of the image data. Color type codes     }
    {represent sums of the following values:                }
    {1 (palette used)                                       }
    {2 (color used)                                         }
    {4 (alpha channel used).                                }
    {Valid values are 0, 2, 3, 4, and 6.                    }
    ColorType,
    {Compression method is a single-byte integer that indicates}
    {the method used to compress the image data. At present,   }
    {only compression method 0 (deflate/inflate compression    }
    {with a sliding window of at most 32768 bytes) is defined. }
    {All standard PNG images must be compressed with this      }
    {scheme. The compression method field is provided for      }
    {possible future expansion or proprietary variants.        }
    {Decoders must check this byte and report an error if it   }
    {holds an unrecognized code                                }
    Compression,
    {Filter method is a single-byte integer that indicates the }
    {preprocessing method applied to the image data before     }
    {compression. At present, only filter method 0  (adaptive  }
    {filtering with five basic filter types) is defined.       }
    Filter,
    {Interlace method is a single-byte integer that indicates  }
    {the transmission order of the image data. Two values are  }
    {currently defined: 0 (no interlace) or 1 (Adam7 interlace)}
    Interlaced: Byte;
  end;

  {tIME Chunk}
  pTIMEChunk = ^TTimeChunk;
  TTIMEChunk = Record
    Year    : Word;
    Month   : Byte;
    Day     : Byte;
    Hour    : Byte;
    Min     : Byte;
    Sec     : Byte;
  end;

  {Pixel memory access}
  pRGBLine = ^TRGBLine;
  TRGBLine = Array[Word] of TRGBTriple;
  pRGBALine = ^TRGBALine;
  TRGBALine = Array[Word] of TRGBQuad;

  {Standard PNG header}
  TPNGHeader = Array[0..7] of Byte;

procedure ConvertBits(Source: array of Pointer; Target: Pointer;
  Count: Cardinal; Mask: Byte; FSourceBPS, FTargetBPS: Byte); forward;

{Forward declaration for the CRC check function}
function crc(chunktype: tchunktype; buf: pbytearray;
  len: Integer): Cardinal; forward;

{:swaps high and low bytes of the given 32 bit value}
function SwapLong(Value: Cardinal): Cardinal;
asm
  BSWAP EAX
end;

{:Register a new chunk kind class}
procedure RegisterNewChunkClass(ChunkType: TChunkType; ChunkClass: TChunkClass);
begin
  {Add to the list}
  ChunkClasses.Add(ChunkType, ChunkClass);
end;

{:Extracted from PNG specification, returns paeth prediction of the values}
function PaethPredictor(a, b, c: Byte): Byte;
var
  p, pa, pb, pc: Integer;
begin
  { a = left, b = above, c = upper left }
  p := a + b - c;        { initial estimate }
  pa := Abs(p - a);      { distances to a, b, c }
  pb := Abs(p - b);
  pc := Abs(p - c);
  { return nearest of a, b, c, breaking ties in order a, b, c }
  if (pa <= pb) and (pa <= pc) then
    Result := a
  else
    if pb <= pc then
      Result := b
    else
      Result := c;
end;

{:Default error handler method}
procedure CallError(ErrorCode: String);
begin
  {Show the error message}
  raise EPNGImageException.CreateFmt('Portable Network Graphics format handler ' +
      'error%s%s', [#13#10#13#10, ErrorCode]);
end;

{Returns the RGB color}
function TChunkTRNS.GetRGBColor: TColor;
var
  Data: pByteArray;
begin

  {Test if the current color type is RGB}
  if IHDR.ColorType <> RGB then
    CallError(PNG_INVALID_COLOR_TYPE);

  Data := fStream.Memory;
  Result := Windows.RGB(Data^[0], Data^[1], Data^[2]);
end;