sxpngutils.pas

skin components for design of your applicastions

    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:PChar);
    procedure CopyNonInterlacedRGB16(Src,Dest,Trans:PChar);
    procedure CopyNonInterlacedPalette148(Src,Dest,Trans:PChar);
    procedure CopyNonInterlacedPalette2(Src,Dest,Trans:PChar);
    procedure CopyNonInterlacedGray2(Src,Dest,Trans:PChar);
    procedure CopyNonInterlacedGrayscale16(Src,Dest,Trans:PChar);
    procedure CopyNonInterlacedRGBAlpha8(Src,Dest,Trans:PChar);
    procedure CopyNonInterlacedRGBAlpha16(Src,Dest,Trans:PChar);
    procedure CopyNonInterlacedGrayscaleAlpha8(Src,Dest,Trans:PChar);
    procedure CopyNonInterlacedGrayscaleAlpha16(Src,Dest,Trans:PChar);
    procedure CopyInterlacedRGB8(const Pass:Byte;Src,Dest,Trans:PChar);
    procedure CopyInterlacedRGB16(const Pass:Byte;Src,Dest,Trans:PChar);
    procedure CopyInterlacedPalette148(const Pass:Byte;Src,Dest,Trans:PChar);
    procedure CopyInterlacedPalette2(const Pass:Byte;Src,Dest,Trans:PChar);
    procedure CopyInterlacedGray2(const Pass:Byte;Src,Dest,Trans:PChar);
    procedure CopyInterlacedGrayscale16(const Pass:Byte;Src,Dest,Trans:PChar);
    procedure CopyInterlacedRGBAlpha8(const Pass:Byte;Src,Dest,Trans:PChar);
    procedure CopyInterlacedRGBAlpha16(const Pass:Byte;Src,Dest,Trans:PChar);
    procedure CopyInterlacedGrayscaleAlpha8(const Pass:Byte;Src,Dest,Trans:PChar);
    procedure CopyInterlacedGrayscaleAlpha16(const Pass:Byte;Src,Dest,Trans: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);
    procedure EncodeInterlacedPalette148(const Pass:Byte;Src,Dest,Trans:PChar);
    procedure EncodeInterlacedGrayscale16(const Pass:Byte;Src,Dest,Trans:PChar);
    procedure EncodeInterlacedRGBAlpha8(const Pass:Byte;Src,Dest,Trans:PChar);
    procedure EncodeInterlacedRGBAlpha16(const Pass:Byte;Src,Dest,Trans:PChar);
    procedure EncodeInterlacedGrayscaleAlpha8(const Pass:Byte;Src,Dest,Trans:PChar);
    procedure EncodeInterlacedGrayscaleAlpha16(const Pass:Byte;Src,Dest,Trans:PChar);
   public
    function LoadFromStream(Stream:TStream;const ChunkName:TChunkName;Size:Integer):Boolean; override;
    function SaveToStream(Stream:TStream):Boolean; override;
  end;

  TChunktIME=class(TChunk)
   private
    fYear:Word;
    fMonth,fDay,fHour,fMinute,fSecond:Byte;
   public
    property Year:Word read fYear write fYear;
    property Month:Byte read fMonth write fMonth;
    property Day:Byte read fDay write fDay;
    property Hour:Byte read fHour write fHour;
    property Minute:Byte read fMinute write fMinute;
    property Second:Byte read fSecond write fSecond;
    function LoadFromStream(Stream:TStream;const ChunkName:TChunkName;Size:Integer):Boolean; override;
    function SaveToStream(Stream:TStream):Boolean; override;
  end;

  TChunktEXt=class(TChunk)
   private
    fKeyword,fText:String;
   public
    property Keyword:String read fKeyword write fKeyword;
    property Text:String read fText write fText;
    function LoadFromStream(Stream:TStream;const ChunkName:TChunkName;Size:Integer):Boolean; override;
    function SaveToStream(Stream:TStream):Boolean; override;
    procedure Assign(Source:TChunk); override;
  end;

  TChunkzTXt=class(TChunktEXt)
    function LoadFromStream(Stream:TStream;const ChunkName:TChunkName;Size:Integer):Boolean; override;
    function SaveToStream(Stream:TStream):Boolean; override;
  end;

procedure RegisterChunk(ChunkClass:TChunkClass);
function update_crc(crc:Cardinal;buf:PByteArray;len:Integer):Cardinal;
function ByteSwap(const a:integer):integer;

function inflateInit_(var strm:TZStreamRec;version:PChar;recsize:Integer):Integer; forward;
function inflate(var strm:TZStreamRec;flush:Integer):Integer; forward;
function inflateEnd(var strm:TZStreamRec):Integer; forward;
function deflateInit_(var strm:TZStreamRec;level:Integer; version:PChar;recsize:Integer):Integer; forward;
function deflate(var strm:TZStreamRec;flush:Integer):Integer; forward;
function deflateEnd(var strm:TZStreamRec):Integer; forward;

const zlib_version='1.1.4';

function adler32(adler:Integer;buf:PChar;len:Integer):Integer;

const
  Z_PARTIAL_FLUSH = 1;
  Z_SYNC_FLUSH    = 2;
  Z_FULL_FLUSH    = 3;

  Z_OK            =  0;
  Z_NEED_DICT     =  2;
  Z_ERRNO         = -1;
  Z_STREAM_ERROR  = -2;
  Z_DATA_ERROR    = -3;
  Z_MEM_ERROR     = -4;
  Z_BUF_ERROR     = -5;
  Z_VERSION_ERROR = -6;

  Z_NO_COMPRESSION      =  0;
  Z_BEST_SPEED          =  1;
  Z_BEST_COMPRESSION    =  9;
  Z_DEFAULT_COMPRESSION = -1;

  Z_FILTERED         = 1;
  Z_HUFFMAN_ONLY     = 2;
  Z_DEFAULT_STRATEGY = 0;

  Z_BINARY   = 0;
  Z_ASCII    = 1;
  Z_UNKNOWN  = 2;

  Z_DEFLATED = 8;

  _z_errmsg:array[0..9]of PChar=(
    'need dictionary',      
    'stream end',
    '',
    'file error',
    'stream error',
    'data error',
    'insufficient memory',
    'buffer error',
    'incompatible version',
    ''
  );

procedure PNGObjectToBitmap32(PNG:TPNGObject;B32:TBitmap32);

implementation

var
  ChunkClasses:TPNGPointerList;
  crc_table:array[0..255]of Cardinal;
  crc_table_computed:Boolean;

{$L obj\deflate.obj}
{$L obj\trees.obj}
{$L obj\inflate.obj}
{$L obj\inftrees.obj}
{$L obj\adler32.obj}
{$L obj\infblock.obj}
{$L obj\infcodes.obj}
{$L obj\infutil.obj}
{$L obj\inffast.obj}

procedure _tr_init; external;
procedure _tr_tally; external;
procedure _tr_flush_block; external;
procedure _tr_align; external;
procedure _tr_stored_block; external;
function adler32; external;
procedure inflate_blocks_new; external;
procedure inflate_blocks; external;
procedure inflate_blocks_reset; external;
procedure inflate_blocks_free; external;
procedure inflate_set_dictionary; external;
procedure inflate_trees_bits; external;
procedure inflate_trees_dynamic; external;
procedure inflate_trees_fixed; external;
procedure inflate_codes_new; external;
procedure inflate_codes; external;
procedure inflate_codes_free; external;
procedure _inflate_mask; external;
procedure inflate_flush; external;
procedure inflate_fast; external;

procedure _memset(P:Pointer;B:Byte;count:Integer);cdecl;
begin
 FillChar(P^,count,B);
end;

procedure _memcpy(dest,source:Pointer;count:Integer);cdecl;
begin
 Move(source^,dest^,count);
end;

function deflateInit_(var strm:TZStreamRec;level:Integer;version:PChar;
  recsize:Integer):Integer; external;
function deflate(var strm:TZStreamRec;flush:Integer):Integer; external;
function deflateEnd(var strm:TZStreamRec):Integer; external;
function inflateInit_(var strm:TZStreamRec;version:PChar;
  recsize:Integer):Integer; external;
function inflate(var strm:TZStreamRec;flush:Integer):Integer; external;
function inflateEnd(var strm:TZStreamRec):Integer; external;
function inflateReset(var strm:TZStreamRec):Integer; external;

function zcalloc(AppData:Pointer;Items,Size:Integer):Pointer;
begin
 GetMem(Result,Items*Size);
end;

procedure zcfree(AppData,Block:Pointer);
begin
 FreeMem(Block);
end;

procedure PNGObjectToBitmap32(PNG:TPNGObject;B32:TBitmap32);
var PB:PByte;
    PC:PColor32;
     C:Cardinal;
begin
 B32.SetSize(PNG.Width,PNG.Height);
 if (PNG.Width=0) or (PNG.Height=0) then exit;
 SetStretchBltMode(B32.Canvas.Handle,COLORONCOLOR);
 StretchDiBits(B32.Canvas.Handle,0,0,PNG.Width,PNG.Height,0,0,
               PNG.Width,PNG.Height,PNG.Header.Data,
               pBitmapInfo(@PNG.Header.BitmapInfo)^,DIB_RGB_COLORS,SRCCOPY);
 if PNG.Header.ColorType in [COLOR_GRAYSCALEALPHA,COLOR_RGBALPHA] then
  begin
   PB:=Pointer(PNG.AlphaScanline[0]);
   if PB<>nil then
    begin
     PC:=Pointer(B32.Bits);
     for C:=0 to PNG.Width*PNG.Height-1 do
      begin
       PC^:=SetAlpha(PC^,PB^);
       Inc(PB); Inc(PC);
      end;
    end;
  end else
   begin
    PC:=Pointer(B32.Bits);
    for C:=0 to PNG.Width*PNG.Height-1 do
     begin
      PC^:=SetAlpha(PC^,$FF);
      Inc(PC);
     end;
   end;
end;

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);
  DrawBitmap:=CreateDIBitmap(dc,srcHeader,CBM_INIT,srcBits,srcBitmapInfo^,DIB_RGB_COLORS);
  OldBitmap:=SelectObject(hdcTemp,DrawBitmap);
  OrgSize.x:=Abs(srcHeader.biWidth);
  OrgSize.y:=Abs(srcHeader.biHeight);
  ptSize.x:=Rect.Right-Rect.Left;
  ptSize.y:=Rect.Bottom-Rect.Top;
  hdcBack:=CreateCompatibleDC(dc);
  hdcObject:=CreateCompatibleDC(dc);
  hdcMem:=CreateCompatibleDC(dc);
  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);
  bmBackOld:=SelectObject(hdcBack,bmAndBack);
  bmObjectOld:=SelectObject(hdcObject,bmAndObject);
  bmMemOld:=SelectObject(hdcMem,bmAndMem);
  cColor:=SetBkColor(hdcTemp,cTransparentColor);
  StretchBlt(hdcObject,0,0,ptSize.x,ptSize.y,hdcTemp,0,0,orgSize.x,orgSize.y,SRCCOPY);
  SetBkColor(hdcTemp,cColor);
  BitBlt(hdcBack,0,0,ptSize.x,ptSize.y,hdcObject,0,0,NOTSRCCOPY);
  BitBlt(hdcMem,0,0,ptSize.x,ptSize.y,dc,Rect.Left,Rect.Top,SRCCOPY);
  BitBlt(hdcMem,0,0,ptSize.x,ptSize.y,hdcObject,0,0,SRCAND);
  StretchBlt(hdcTemp,0,0,OrgSize.x,OrgSize.y,hdcBack,0,0,PtSize.x,PtSize.y,SRCAND);
  StretchBlt(hdcMem,0,0,ptSize.x,ptSize.y,hdcTemp,0,0,OrgSize.x,OrgSize.y,SRCPAINT);
  BitBlt(dc,Rect.Left,Rect.Top,ptSize.x,ptSize.y,hdcMem,0,0,SRCCOPY);
  DeleteObject(SelectObject(hdcBack,bmBackOld));
  DeleteObject(SelectObject(hdcObject,bmObjectOld));
  DeleteObject(SelectObject(hdcMem,bmMemOld));
  DeleteObject(SelectObject(hdcTemp,OldBitmap));
  DeleteDC(hdcMem);
  DeleteDC(hdcBack);
  DeleteDC(hdcObject);
  DeleteDC(hdcTemp);
end;

procedure make_crc_table;
var c:Cardinal;
  n,k:Integer;
begin
 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;
 crc_table_computed:=True;
end;

function update_crc(crc:Cardinal;buf:PByteArray;len:Integer):Cardinal;
var c:Cardinal;
    n:Integer;
begin
 c:=crc;
 if not crc_table_computed then
  make_crc_table;
 for n:=0 to len-1 do
  c:=crc_table[(c xor buf^[n]) and $FF] xor (c shr 8);
 Result:=c;
end;

function PaethPredictor(a,b,c:Byte):Byte;
var pa,pb,pc:Integer;
begin
 pa:=Abs(b-c);
 pb:=Abs(a-c);
 pc:=Abs(a+b-c*2);
 if (pa<=pb) and (pa<=pc) then Result:=a else
  if pb<=pc then Result:=b else Result:=c;
end;

function ByteSwap(const A:Integer):Integer;
asm
 BSWAP EAX
end;

function ByteSwap16(A:Word):Word;
asm
 BSWAP EAX
 SHR   EAX,16
end;

function BytesForPixels(const Pixels:Integer;const ColorType,BitDepth:Byte):Integer;
begin
 case ColorType of
  COLOR_GRAYSCALE,
  COLOR_PALETTE:        Result:=(Pixels*BitDepth+7) div 8;
  COLOR_RGB:            Result:=(Pixels*BitDepth*3) div 8;
  COLOR_GRAYSCALEALPHA: Result:=(Pixels*BitDepth*2) div 8;
  COLOR_RGBALPHA:       Result:=(Pixels*BitDepth*4) div 8;
  else                  Result:=0;
 end;
end;

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

procedure RegisterChunk(ChunkClass:TChunkClass);
var NewClass:PChunkClassInfo;
begin
  if ChunkClasses=nil then ChunkClasses:=TPNGPointerList.Create(nil);
  new(NewClass);
  NewClass^.ClassName:=ChunkClass;
  ChunkClasses.Add(NewClass);
end;

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;

procedure RegisterCommonChunks;
begin
  RegisterChunk(TChunkIEND);
  RegisterChunk(TChunkIHDR);
  RegisterChunk(TChunkIDAT);
  RegisterChunk(TChunkPLTE);
  RegisterChunk(TChunkgAMA);
  RegisterChunk(TChunktRNS);
  RegisterChunk(TChunktIME);
  RegisterChunk(TChunktEXt);
  RegisterChunk(TChunkzTXt);
end;

function CreateClassChunk(Owner:TPNGObject;Name:TChunkName):TChunk;
var
  i:Integer;
  NewChunk:TChunkClass;
begin
  NewChunk:=TChunk;