pngimage.pas

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

  public
    {Keyword and text}
    property Keyword: String read fKeyword write fKeyword;
    property Text: String read fText write fText;
    {Loads the chunk from a stream}
    function LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
      Size: Integer): Boolean; override;
    {Saves the chunk to a stream}
    function SaveToStream(Stream: TStream): Boolean; override;
    {Assigns from another TChunk}
    procedure Assign(Source: TChunk); override;
  end;

  {zTXT chunk}
  TChunkzTXt = class(TChunktEXt)
    {Loads the chunk from a stream}
    function LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
      Size: Integer): Boolean; override;
    {Saves the chunk to a stream}
    function SaveToStream(Stream: TStream): Boolean; override;
  end;

{Here we test if it's c++ builder or delphi version 3 or less}
{$IFDEF VER110}{$DEFINE DelphiBuilder3Less}{$ENDIF}
{$IFDEF VER100}{$DEFINE DelphiBuilder3Less}{$ENDIF}
{$IFDEF VER93}{$DEFINE DelphiBuilder3Less}{$ENDIF}
{$IFDEF VER90}{$DEFINE DelphiBuilder3Less}{$ENDIF}
{$IFDEF VER80}{$DEFINE DelphiBuilder3Less}{$ENDIF}


{Registers a new chunk class}
procedure RegisterChunk(ChunkClass: TChunkClass);
{Calculates crc}
function update_crc(crc: {$IFNDEF DelphiBuilder3Less}Cardinal{$ELSE}Integer
  {$ENDIF}; buf: pByteArray; len: Integer): Cardinal;
{Invert bytes using assembly}
function ByteSwap(const a: integer): integer;

implementation

var
  ChunkClasses: TPngPointerList;
  {Table of CRCs of all 8-bit messages}
  crc_table: Array[0..255] of Cardinal;
  {Flag: has the table been computed? Initially false}
  crc_table_computed: Boolean;

{Draw transparent image using transparent color}
procedure DrawTransparentBitmap(dc: HDC; srcBits: Pointer;
  var srcHeader: TBitmapInfoHeader;
  srcBitmapInfo: pBitmapInfo; Rect: TRect; cTransparentColor: COLORREF);
var
  cColor:   COLORREF;
  bmAndBack, bmAndObject, bmAndMem: HBITMAP;
  bmBackOld, bmObjectOld, bmMemOld: HBITMAP;
  hdcMem, hdcBack, hdcObject, hdcTemp: HDC;
  ptSize, orgSize: TPOINT;
  OldBitmap, DrawBitmap: HBITMAP;
begin
  hdcTemp := CreateCompatibleDC(dc);
  // Select the bitmap
  DrawBitmap := CreateDIBitmap(dc, srcHeader, CBM_INIT, srcBits, srcBitmapInfo^,
    DIB_RGB_COLORS);
  OldBitmap := SelectObject(hdcTemp, DrawBitmap);

  // Sizes
  OrgSize.x := abs(srcHeader.biWidth);
  OrgSize.y := abs(srcHeader.biHeight);
  ptSize.x := Rect.Right - Rect.Left;        // Get width of bitmap
  ptSize.y := Rect.Bottom - Rect.Top;        // Get height of bitmap

  // Create some DCs to hold temporary data.
  hdcBack  := CreateCompatibleDC(dc);
  hdcObject := CreateCompatibleDC(dc);
  hdcMem   := CreateCompatibleDC(dc);

  // Create a bitmap for each DC. DCs are required for a number of
  // GDI functions.

  // Monochrome DCs
  bmAndBack  := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);
  bmAndObject := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);

  bmAndMem   := CreateCompatibleBitmap(dc, ptSize.x, ptSize.y);

  // Each DC must select a bitmap object to store pixel data.
  bmBackOld  := SelectObject(hdcBack, bmAndBack);
  bmObjectOld := SelectObject(hdcObject, bmAndObject);
  bmMemOld   := SelectObject(hdcMem, bmAndMem);

  // Set the background color of the source DC to the color.
  // contained in the parts of the bitmap that should be transparent
  cColor := SetBkColor(hdcTemp, cTransparentColor);

  // Create the object mask for the bitmap by performing a BitBlt
  // from the source bitmap to a monochrome bitmap.
  StretchBlt(hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0,
    orgSize.x, orgSize.y, SRCCOPY);

  // Set the background color of the source DC back to the original
  // color.
  SetBkColor(hdcTemp, cColor);

  // Create the inverse of the object mask.
  BitBlt(hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0,
       NOTSRCCOPY);

  // Copy the background of the main DC to the destination.
  BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, dc, Rect.Left, Rect.Top,
       SRCCOPY);

  // Mask out the places where the bitmap will be placed.
  BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND);

  // Mask out the transparent colored pixels on the bitmap.
//  BitBlt(hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND);
  StretchBlt(hdcTemp, 0, 0, OrgSize.x, OrgSize.y, hdcBack, 0, 0,
    PtSize.x, PtSize.y, SRCAND);

  // XOR the bitmap with the background on the destination DC.
  StretchBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0,
    OrgSize.x, OrgSize.y, SRCPAINT);

  // Copy the destination to the screen.
  BitBlt(dc, Rect.Left, Rect.Top, ptSize.x, ptSize.y, hdcMem, 0, 0,
       SRCCOPY);

  // Delete the memory bitmaps.
  DeleteObject(SelectObject(hdcBack, bmBackOld));
  DeleteObject(SelectObject(hdcObject, bmObjectOld));
  DeleteObject(SelectObject(hdcMem, bmMemOld));
  DeleteObject(SelectObject(hdcTemp, OldBitmap));

  // Delete the memory DCs.
  DeleteDC(hdcMem);
  DeleteDC(hdcBack);
  DeleteDC(hdcObject);
  DeleteDC(hdcTemp);
end;

{Make the table for a fast CRC.}
procedure make_crc_table;
var
  c: Cardinal;
  n, k: Integer;
begin

  {fill the crc table}
  for n := 0 to 255 do
  begin
    c := Cardinal(n);
    for k := 0 to 7 do
    begin
      if Boolean(c and 1) then
        c := $edb88320 xor (c shr 1)
      else
        c := c shr 1;
    end;
    crc_table[n] := c;
  end;

  {The table has already being computated}
  crc_table_computed := true;
end;

{Update a running CRC with the bytes buf[0..len-1]--the CRC
 should be initialized to all 1's, and the transmitted value
 is the 1's complement of the final running CRC (see the
 crc() routine below)).}
function update_crc(crc: {$IFNDEF DelphiBuilder3Less}Cardinal{$ELSE}Integer
  {$ENDIF}; buf: pByteArray; len: Integer): Cardinal;
var
  c: Cardinal;
  n: Integer;
begin
  c := crc;

  {Create the crc table in case it has not being computed yet}
  if not crc_table_computed then make_crc_table;

  {Update}
  for n := 0 to len - 1 do
    c := crc_table[(c XOR buf^[n]) and $FF] XOR (c shr 8);

  {Returns}
  Result := c;
end;

{$IFNDEF UseDelphi}
  function FileExists(Filename: String): Boolean;
  var
    FindFile: THandle;
    FindData: TWin32FindData;
  begin
    FindFile := FindFirstFile(PChar(Filename), FindData);
    Result := FindFile <> INVALID_HANDLE_VALUE;
    if Result then Windows.FindClose(FindFile);
  end;


{$ENDIF}

{$IFNDEF UseDelphi}
  {Exception implementation}
  constructor Exception.Create(Msg: String);
  begin
  end;
{$ENDIF}

{Calculates the paeth predictor}
function PaethPredictor(a, b, c: Byte): Byte;
var
  pa, pb, pc: Integer;
begin
  { a = left, b = above, c = upper left }
  pa := abs(b - c);      { distances to a, b, c }
  pb := abs(a - c);
  pc := abs(a + b - c * 2);

  { 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;

{Invert bytes using assembly}
function ByteSwap(const a: integer): integer;
asm
  bswap eax
end;
function ByteSwap16(inp:word): word;
asm
  bswap eax
  shr   eax, 16
end;

{Calculates number of bytes for the number of pixels using the}
{color mode in the paramenter}
function BytesForPixels(const Pixels: Integer; const ColorType,
  BitDepth: Byte): Integer;
begin
  case ColorType of
    {Palette and grayscale contains a single value, for palette}
    {an value of size 2^bitdepth pointing to the palette index}
    {and grayscale the value from 0 to 2^bitdepth with color intesity}
    COLOR_GRAYSCALE, COLOR_PALETTE:
      Result := (Pixels * BitDepth + 7) div 8;
    {RGB contains 3 values R, G, B with size 2^bitdepth each}
    COLOR_RGB:
      Result := (Pixels * BitDepth * 3) div 8;
    {Contains one value followed by alpha value booth size 2^bitdepth}
    COLOR_GRAYSCALEALPHA:
      Result := (Pixels * BitDepth * 2) div 8;
    {Contains four values size 2^bitdepth, Red, Green, Blue and alpha}
    COLOR_RGBALPHA:
      Result := (Pixels * BitDepth * 4) div 8;
    else
      Result := 0;
  end {case ColorType}
end;

type
  pChunkClassInfo = ^TChunkClassInfo;
  TChunkClassInfo = record
    ClassName: TChunkClass;
  end;

{Register a chunk type}
procedure RegisterChunk(ChunkClass: TChunkClass);
var
  NewClass: pChunkClassInfo;
begin
  {In case the list object has not being created yet}
  if ChunkClasses = nil then ChunkClasses := TPngPointerList.Create(nil);

  {Add this new class}
  new(NewClass);
  NewClass^.ClassName := ChunkClass;
  ChunkClasses.Add(NewClass);
end;

{Free chunk class list}
procedure FreeChunkClassList;
var
  i: Integer;
begin
  if (ChunkClasses <> nil) then
  begin
    FOR i := 0 TO ChunkClasses.Count - 1 do
      Dispose(pChunkClassInfo(ChunkClasses.Item[i]));
    ChunkClasses.Free;
  end;
end;

{Registering of common chunk classes}
procedure RegisterCommonChunks;
begin
  {Important chunks}
  RegisterChunk(TChunkIEND);
  RegisterChunk(TChunkIHDR);
  RegisterChunk(TChunkIDAT);
  RegisterChunk(TChunkPLTE);
  RegisterChunk(TChunkgAMA);
  RegisterChunk(TChunktRNS);

  {Not so important chunks}
  RegisterChunk(TChunktIME);
  RegisterChunk(TChunktEXt);
  RegisterChunk(TChunkzTXt);
end;

{Creates a new chunk of this class}
function CreateClassChunk(Owner: TPngObject; Name: TChunkName): TChunk;
var
  i       : Integer;
  NewChunk: TChunkClass;
begin
  {Looks for this chunk}
  NewChunk := TChunk;  {In case there is no registered class for this}

  {Looks for this class in all registered chunks}
  if Assigned(ChunkClasses) then
    FOR i := 0 TO ChunkClasses.Count - 1 DO
    begin
      if pChunkClassInfo(ChunkClasses.Item[i])^.ClassName.GetName = Name then
      begin
        NewChunk := pChunkClassInfo(ChunkClasses.Item[i])^.ClassName;
        break;
      end;
    end;

  {Returns chunk class}
  Result := NewChunk.Create(Owner);
  Result.fName := Name;
end;

{ZLIB support}

const
  ZLIBAllocate = High(Word);

{Initializes ZLIB for decompression}
function ZLIBInitInflate(Stream: TStream): TZStreamRec2;
begin
  {Fill record}
  Fillchar(Result, SIZEOF(TZStreamRec2), #0);

  {Set internal record information}
  with Result do
  begin
    GetMem(Data, ZLIBAllocate);
    fStream := Stream;
  end;

  {Init decompression}
  InflateInit_(Result.zlib, zlib_version, SIZEOF(TZStreamRec));
end;

{Initializes ZLIB for compression}
function ZLIBInitDeflate(Stream: TStream;
  Level: TCompressionlevel; Size: Cardinal): TZStreamRec2;
begin
  {Fill record}
  Fillchar(Result, SIZEOF(TZStreamRec2), #0);

  {Set internal record information}
  with Result, ZLIB do
  begin
    GetMem(Data, Size);
    fStream := Stream;
    next_out := Data;
    avail_out := Size;
  end;

  {Inits compression}
  deflateInit_(Result.zlib, Level, zlib_version, sizeof(TZStreamRec));
end;

{Terminates ZLIB for compression}
procedure ZLIBTerminateDeflate(var ZLIBStream: TZStreamRec2);
begin
  {Terminates decompression}
  DeflateEnd(ZLIBStream.zlib);
  {Free internal record}
  FreeMem(ZLIBStream.Data, ZLIBAllocate);
end;

{Terminates ZLIB for decompression}
procedure ZLIBTerminateInflate(var ZLIBStream: TZStreamRec2);
begin
  {Terminates decompression}
  InflateEnd(ZLIBStream.zlib);
  {Free internal record}
  FreeMem(ZLIBStream.Data, ZLIBAllocate);
end;

{Decompresses ZLIB into a memory address}
function DecompressZLIB(const Input: Pointer; InputSize: Integer;
  var Output: Pointer; var OutputSize: Integer;
  var ErrorOutput: String): Boolean;
var
  StreamRec : TZStreamRec;