bspngimage.pas

BusinessSkinForm的控件包与实例

{*******************************************************************}
{                                                                   }
{       Almediadev Visual Component Library                         }
{       BusinessSkinForm                                            }
{       Version 6.50                                                }
{                                                                   }
{       Copyright (c) 2000-2008 Almediadev                          }
{       ALL RIGHTS RESERVED                                         }
{                                                                   }
{       Home:  http://www.almdev.com                                }
{       Support: [e-mail]                                 }
{                                                                   }
{*******************************************************************}

unit bspngimage;

interface

{$TYPEDADDRESS OFF}
{$RANGECHECKS OFF} 
{$J+}
//{$DEFINE RegisterPNG}

{$IFDEF VER200}
 Uses PngImage;

 type
   TbsPngImage = class(TPngImage);

{$ELSE}

uses
 Windows, Classes, Graphics, SysUtils, bszlib;

const
  Z_NO_FLUSH      = 0;
  Z_FINISH        = 4;
  Z_STREAM_END    = 1;

  FILTER_NONE    = 0;
  FILTER_SUB     = 1;
  FILTER_UP      = 2;
  FILTER_AVERAGE = 3;
  FILTER_PAETH   = 4;

  COLOR_GRAYSCALE      = 0;
  COLOR_RGB            = 2;
  COLOR_PALETTE        = 3;
  COLOR_GRAYSCALEALPHA = 4;
  COLOR_RGBALPHA       = 6;

type
  TRGBLine = array[word] of TRGBTriple;
  pRGBLine = ^TRGBLine;

  TMAXBITMAPINFO = packed record
    bmiHeader: TBitmapInfoHeader;
    bmiColors: packed array[0..255] of TRGBQuad;
  end;

  TbsPngTransparencyMode = (bsptmNone, bsptmBit, bsptmPngLayerial);
  pCardinal = ^Cardinal;
  pRGBPixel = ^TRGBPixel;
  TRGBPixel = packed record
    B, G, R: Byte;
  end;

  TByteArray = Array[Word] of Byte;
  PByteArray = ^TByteArray;

  TbsPngImage = class;
  PPointerArray = ^TPointerArray;
  TPointerArray = Array[Word] of Pointer;

  TbsPngPointerList = class
  private
    fOwner: TbsPngImage;
    fCount : Cardinal;
    fMemory: pPointerArray;
    function GetItem(Index: Cardinal): Pointer;
    procedure SetItem(Index: Cardinal; const Value: Pointer);
  protected
    function Remove(Value: Pointer): Pointer; virtual;
    procedure Insert(Value: Pointer; Position: Cardinal);
    procedure Add(Value: Pointer);
    property Item[Index: Cardinal]: Pointer read GetItem write SetItem;
    procedure SetSize(const Size: Cardinal);
    property Owner: TbsPngImage read fOwner;
  public
    constructor Create(AOwner: TbsPngImage);
    destructor Destroy; override;
    property Count: Cardinal read fCount write SetSize;
  end;

  TbsPngLayer = class;
  TbsPngLayerClass = class of TbsPngLayer;

  TbsPngList = class(TbsPngPointerList)
  private
    function GetItem(Index: Cardinal): TbsPngLayer;
  public
    function FindPngLayer(PngLayerClass: TbsPngLayerClass): TbsPngLayer;
    procedure RemovePngLayer(PngLayer: TbsPngLayer); overload;
    function Add(PngLayerClass: TbsPngLayerClass): TbsPngLayer;
    function ItemFromClass(PngLayerClass: TbsPngLayerClass): TbsPngLayer;
    property Item[Index: Cardinal]: TbsPngLayer read GetItem;
  end;

  TbsPngLayerIHDR = class;
  TbsPngLayerpHYs = class;
  TbsInterlaceMethod = (bsimNone, bsimAdam7);
  TbsCompressionLevel = 0..9;
  TbsPngFilter = (bspfNone, bspfSub, bspfUp, bspfAverage, bspfPaeth);
  TbsPngFilters = set of TbsPngFilter;

  TbsPngImage = class(TGraphic)
  private
    fMaxIdatSize: Integer;
    fInterlaceMethod: TbsInterlaceMethod;
    fPngLayerList: TbsPngList;
    fCanvas: TCanvas;
    fFilters: TbsPngFilters;
    fCompressionLevel: TbsCompressionLevel;
    procedure ClearPngLayers;
    function HeaderPresent: Boolean;
    procedure GetPixelInfo(var LineSize, Offset: Cardinal);
    procedure SetMaxIdatSize(const Value: Integer);
    function GetAlphaScanline(const LineIndex: Integer): pByteArray;
    function GetScanline(const LineIndex: Integer): Pointer;
    function GetExtraScanline(const LineIndex: Integer): Pointer;
    function GetTransparencyMode: TbsPngTransparencyMode;
    function GetTransparentColor: TColor;
    procedure SetTransparentColor(const Value: TColor);
  protected
    InverseGamma: Array[Byte] of Byte;
    BeingCreated: Boolean;
    procedure InitializeGamma;
    function GetPalette: HPALETTE; override;
    procedure SetPalette(Value: HPALETTE); override;
    procedure DoSetPalette(Value: HPALETTE; const UpdateColors: Boolean);
    function GetWidth: Integer; override;
    function GetHeight: Integer; override;
    procedure SetWidth(Value: Integer);  override;
    procedure SetHeight(Value: Integer); override;
    procedure AssignPNG(Source: TbsPngImage);
    function GetEmpty: Boolean; override; 
    function GetHeader: TbsPngLayerIHDR;
    procedure DrawPngLayerialTrans(DC: HDC; Rect: TRect);
    function GetTransparent: Boolean; override;
    function GetPixels(const X, Y: Integer): TColor; virtual;
    procedure SetPixels(const X, Y: Integer; const Value: TColor); virtual;
  public
    GammaTable: Array[Byte] of Byte;
    procedure Resize(const CX, CY: Integer);
    procedure CreateAlpha;
    procedure RemoveTransparency;
    procedure Assign(Source: TPersistent);override;
    procedure AssignTo(Dest: TPersistent);override;
    procedure AssignHandle(Handle: HBitmap; Transparent: Boolean;
      TransparentColor: ColorRef);
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    constructor Create; override;
    constructor CreateBlank(ColorType, Bitdepth: Cardinal; cx, cy: Integer);
    destructor Destroy; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromResourceName(Instance: HInst; const Name: String);
    procedure LoadFromResourceID(Instance: HInst; ResID: Integer);
    property TransparentColor: TColor read GetTransparentColor write
      SetTransparentColor;
    property Scanline[const Index: Integer]: Pointer read GetScanline;
    property ExtraScanline[const Index: Integer]: Pointer read GetExtraScanline;
    property AlphaScanline[const Index: Integer]: pByteArray read
      GetAlphaScanline;
    property Canvas: TCanvas read fCanvas;
    property Header: TbsPngLayerIHDR read GetHeader;
    property TransparencyMode: TbsPngTransparencyMode read GetTransparencyMode;

    property Width: Integer read GetWidth;
    property Height: Integer read GetHeight;
    property InterlaceMethod: TbsInterlaceMethod read fInterlaceMethod
      write fInterlaceMethod;
    property Filters: TbsPngFilters read fFilters write fFilters;
    property MaxIdatSize: Integer read fMaxIdatSize write SetMaxIdatSize;
    property Empty: Boolean read GetEmpty;
    property CompressionLevel: TbsCompressionLevel read fCompressionLevel
      write fCompressionLevel;
    property PngLayers: TbsPngList read fPngLayerList;
    property Pixels[const X, Y: Integer]: TColor read GetPixels write SetPixels;
  end;

  TbsPngLayerName = Array[0..3] of Char;

  TbsPngLayer = class
  private
    fData: Pointer;
    fDataSize: Cardinal;
    fOwner: TbsPngImage;
    fName: TbsPngLayerName;
    function GetHeader: TbsPngLayerIHDR;
    function GetIndex: Integer;
    class function GetName: String; virtual;
    function GetPngLayerName: String;
  public
    procedure ResizeData(const NewSize: Cardinal);
    procedure Assign(Source: TbsPngLayer); virtual;
    constructor Create(Owner: TbsPngImage); virtual;
    destructor Destroy; override;
    function LoadFromStream(Stream: TStream; const PngLayerName: TbsPngLayerName;
      Size: Integer): Boolean; virtual;
    function SaveData(Stream: TStream): Boolean;
    function SaveToStream(Stream: TStream): Boolean; virtual;
    property Index: Integer read GetIndex;
    property Header: TbsPngLayerIHDR read GetHeader;
    property Data: Pointer read fData;
    property DataSize: Cardinal read fDataSize;
    property Owner: TbsPngImage read fOwner;
    property Name: String read GetPngLayerName;
  end;

  TbsPngLayerIEND = class(TbsPngLayer); 

  pIHDRData = ^TIHDRData;
  TIHDRData = packed record
    Width, Height: Cardinal;
    BitDepth,
    ColorType,
    CompressionMethod,
    FilterMethod,
    InterlaceMethod: Byte;
  end;

  TbsPngLayerIHDR = class(TbsPngLayer)
  private
    ImageHandle: HBitmap;
    ImageDC: HDC;
    ImagePalette: HPalette;
    HasPalette: Boolean;
    BitmapInfo: TMaxBitmapInfo;
    ExtraImageData: Pointer;
    ImageData: pointer;
    ImageAlpha: Pointer;
    IHDRData: TIHDRData;
  protected
    BytesPerRow: Integer;
    function CreateGrayscalePalette(Bitdepth: Integer): HPalette;
    procedure PaletteToDIB(Palette: HPalette);
    procedure PrepareImageData;
    procedure FreeImageData;
  public
    function LoadFromStream(Stream: TStream; const PngLayerName: TbsPngLayerName;
      Size: Integer): Boolean; override;
    function SaveToStream(Stream: TStream): Boolean; override;
    constructor Create(Owner: TbsPngImage); override;
    destructor Destroy; override;
    procedure Assign(Source: TbsPngLayer); override;

    property ImageHandleValue: HBitmap read ImageHandle;
    property Width: Cardinal read IHDRData.Width write IHDRData.Width;
    property Height: Cardinal read IHDRData.Height write IHDRData.Height;
    property BitDepth: Byte read IHDRData.BitDepth write IHDRData.BitDepth;
    property ColorType: Byte read IHDRData.ColorType write IHDRData.ColorType;
    property CompressionMethod: Byte read IHDRData.CompressionMethod
      write IHDRData.CompressionMethod;
    property FilterMethod: Byte read IHDRData.FilterMethod
      write IHDRData.FilterMethod;
    property InterlaceMethod: Byte read IHDRData.InterlaceMethod
      write IHDRData.InterlaceMethod;

  end;

  pUnitType = ^TUnitType;
  TUnitType = (utUnknown, utMeter);
  TbsPngLayerpHYs = class(TbsPngLayer)
  private
    fPPUnitX, fPPUnitY: Cardinal;
    fUnit: TUnitType;
  public
    function LoadFromStream(Stream: TStream; const PngLayerName: TbsPngLayerName;
      Size: Integer): Boolean; override;
    function SaveToStream(Stream: TStream): Boolean; override;
    procedure Assign(Source: TbsPngLayer); override;
    property PPUnitX: Cardinal read fPPUnitX write fPPUnitX;
    property PPUnitY: Cardinal read fPPUnitY write fPPUnitY;
    property UnitType: TUnitType read fUnit write fUnit;
  end;

  TbsPngLayergAMA = class(TbsPngLayer)
  private
    function GetValue: Cardinal;
    procedure SetValue(const Value: Cardinal);
  public
    function LoadFromStream(Stream: TStream; const PngLayerName: TbsPngLayerName;
      Size: Integer): Boolean; override;
    constructor Create(Owner: TbsPngImage); override;
    procedure Assign(Source: TbsPngLayer); override;
    property Gamma: Cardinal read GetValue write SetValue;
  end;

  TZStreamRec2 = packed record
    ZLIB: z_stream;
    Data: Pointer;
    fStream   : TStream;
  end;

  TbsPngLayerPLTE = class(TbsPngLayer)
  protected
    fCount: Integer;
  private
    function GetPaletteItem(Index: Byte): TRGBQuad;
  public
    property Item[Index: Byte]: TRGBQuad read GetPaletteItem;
    property Count: Integer read fCount;
    function LoadFromStream(Stream: TStream; const PngLayerName: TbsPngLayerName;
      Size: Integer): Boolean; override;
    function SaveToStream(Stream: TStream): Boolean; override;
    procedure Assign(Source: TbsPngLayer); override;
  end;

  TbsPngLayertRNS = class(TbsPngLayer)
  private
    fBitTransparency: Boolean;
    function GetTransparentColor: ColorRef;
    procedure SetTransparentColor(const Value: ColorRef);
  public
    PaletteValues: Array[Byte] of Byte;
    function LoadFromStream(Stream: TStream; const PngLayerName: TbsPngLayerName;
      Size: Integer): Boolean; override;
    function SaveToStream(Stream: TStream): Boolean; override;
    procedure Assign(Source: TbsPngLayer); override;
    property BitTransparency: Boolean read fBitTransparency;
    property TransparentColor: ColorRef read GetTransparentColor write
      SetTransparentColor;
  end;

  TbsPngLayerIDAT = class(TbsPngLayer)
  private
    Header: TbsPngLayerIHDR;
    ImageWidth, ImageHeight: Integer;
    Row_Bytes, Offset : Cardinal;
    Encode_Buffer: Array[0..5] of pByteArray;
    Row_Buffer: Array[Boolean] of pByteArray;
    RowUsed: Boolean;
    EndPos: Integer;
    procedure FilterRow;
    function FilterToEncode: Byte;
    function IDATZlibRead(var ZLIBStream: TZStreamRec2; Buffer: Pointer;
      Count: Integer; var EndPos: Integer; var crcfile: Cardinal): Integer;
    procedure IDATZlibWrite(var ZLIBStream: TZStreamRec2; Buffer: Pointer;
      const Length: Cardinal);
    procedure FinishIDATZlib(var ZLIBStream: TZStreamRec2);
    procedure PreparePalette;
  protected
    procedure DecodeInterlacedAdam7(Stream: TStream;
      var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal);
    procedure DecodeNonInterlaced(Stream: TStream;
      var ZLIBStream: TZStreamRec2; const Size: Integer;
      var crcfile: Cardinal);
  protected
    procedure EncodeNonInterlaced(Stream: TStream;
      var ZLIBStream: TZStreamRec2);
    procedure EncodeInterlacedAdam7(Stream: TStream;
      var ZLIBStream: TZStreamRec2);
  protected
    procedure CopyNonInterlacedRGB8(
      Src, Dest, Trans, Extra: pChar);
    procedure CopyNonInterlacedRGB16(
      Src, Dest, Trans, Extra: pChar);
    procedure CopyNonInterlacedPalette148(
      Src, Dest, Trans, Extra: pChar);
    procedure CopyNonInterlacedPalette2(
      Src, Dest, Trans, Extra: pChar);
    procedure CopyNonInterlacedGray2(
      Src, Dest, Trans, Extra: pChar);
    procedure CopyNonInterlacedGrayscale16(
      Src, Dest, Trans, Extra: pChar);
    procedure CopyNonInterlacedRGBAlpha8(
      Src, Dest, Trans, Extra: pChar);
    procedure CopyNonInterlacedRGBAlpha16(
      Src, Dest, Trans, Extra: pChar);
    procedure CopyNonInterlacedGrayscaleAlpha8(
      Src, Dest, Trans, Extra: pChar);
    procedure CopyNonInterlacedGrayscaleAlpha16(
      Src, Dest, Trans, Extra: pChar);
    procedure CopyInterlacedRGB8(const Pass: Byte;
      Src, Dest, Trans, Extra: pChar);
    procedure CopyInterlacedRGB16(const Pass: Byte;
      Src, Dest, Trans, Extra: pChar);
    procedure CopyInterlacedPalette148(const Pass: Byte;
      Src, Dest, Trans, Extra: pChar);
    procedure CopyInterlacedPalette2(const Pass: Byte;
      Src, Dest, Trans, Extra: pChar);
    procedure CopyInterlacedGray2(const Pass: Byte;
      Src, Dest, Trans, Extra: pChar);
    procedure CopyInterlacedGrayscale16(const Pass: Byte;
      Src, Dest, Trans, Extra: pChar);
    procedure CopyInterlacedRGBAlpha8(const Pass: Byte;
      Src, Dest, Trans, Extra: pChar);
    procedure CopyInterlacedRGBAlpha16(const Pass: Byte;
      Src, Dest, Trans, Extra: pChar);
    procedure CopyInterlacedGrayscaleAlpha8(const Pass: Byte;
      Src, Dest, Trans, Extra: pChar);
    procedure CopyInterlacedGrayscaleAlpha16(const Pass: Byte;
      Src, Dest, Trans, Extra: pChar);
  protected
    procedure EncodeNonInterlacedRGB8(Src, Dest, Trans: pChar);
    procedure EncodeNonInterlacedRGB16(Src, Dest, Trans: pChar);
    procedure EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pChar);
    procedure EncodeNonInterlacedPalette148(Src, Dest, Trans: pChar);
    procedure EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pChar);
    procedure EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pChar);
    procedure EncodeNonInterlacedGrayscaleAlpha8(Src, Dest, Trans: pChar);
    procedure EncodeNonInterlacedGrayscaleAlpha16(Src, Dest, Trans: pChar);
    procedure EncodeInterlacedRGB8(const Pass: Byte; Src, Dest, Trans: pChar);
    procedure EncodeInterlacedRGB16(const Pass: Byte; Src, Dest, Trans: pChar);