Delphi/FastReport_2022_VCL
Delphi/FastReport_2022_VCL
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
b867fa72b3
FastReport_2022_VCL/Source/frxpngimage.pas

5829 lines
178 KiB
ObjectPascal
Raw Normal View History

Inicijalizacija
2024-01-01 16:13:08 +01:00
{Portable Network Graphics Delphi 1.564 (31 July 2006) }
{This is a full, open sourced implementation of png in Delphi }
{It has native support for most of png features including the }
{partial transparency, gamma and more. }
{For the latest version, please be sure to check my website }
{http://pngdelphi.sourceforge.net }
{Gustavo Huffenbacher Daud (gustavo.daud@terra.com.br) }
{
Version 1.564
2006-07-25 BUG 1 - There was one GDI Palette object leak
when assigning from other PNG (fixed)
BUG 2 - Loosing color information when assigning png
to bmp on lower screen depth system
BUG 3 - There was a bug in TStream.GetSize
(fixed thanks to Vladimir Panteleev)
IMPROVE 1 - When assigning png to bmp now alpha information
is drawn (simulated into a white background)
Version 1.563
2006-07-25 BUG 1 - There was a memory bug in the main component
destructor (fixed thanks to Steven L Brenner)
BUG 2 - The packages name contained spaces which was
causing some strange bugs in Delphi
(fixed thanks to Martijn Saly)
BUG 3 - Lots of fixes when handling palettes
(bugs implemented in the last version)
Fixed thanks to Gabriel Corneanu!!!
BUG 4 - CreateAlpha was raising an error because it did
not resized the palette chunk it created;
Fixed thanks to Miha Sokolov
IMPROVE 1 - Renamed the pngzlib.pas unit to zlibpas.pas
as a tentative to all libraries use the same
shared zlib implementation and to avoid including
two or three times the same P-Code.
(Gabriel Corneanu idea)
Version 1.561
2006-05-17 BUG 1 - There was a bug in the method that draws semi
transparent images (a memory leak). fixed.
Version 1.56
2006-05-09 - IMPROVE 1 - Delphi standard TCanvas support is now implemented
IMPROVE 2 - The PNG files may now be resized and created from
scratch using CreateBlank, Resize, Width and Height
BUG 1 - Fixed some bugs on handling tRNS transparencies
BUG 2 - Fixed bugs related to palette handling
Version 1.535
2006-04-21 - IMPROVE 1 - Now the library uses the latest ZLIB release (1.2.3)
(thanks to: Roberto Della Pasqua
http://www.dellapasqua.com/delphizlib/)
Version 1.53
2006-04-14 -
BUG 1 - Remove transparency was not working for
RGB Alpha and Grayscale alpha. fixed
BUG 2 - There was a bug were compressed text chunks no keyword
name could not be read
IMPROVE 1 - Add classes and methods to work with the pHYs chunk
(including TPNGObject.DrawUsingPixelInformation)
IMPROVE 3 - Included a property Version to return the library
version
IMPROVE 4 - New polish translation (thanks to Piotr Domanski)
IMPROVE 5 - Now packages for delphi 5, 6, 7, 2005 and 2006
Also Martijn Saly (thany) made some improvements in the library:
IMPROVE 1 - SetPixel now works with grayscale
IMPROVE 2 - Palette property now can be written using a
windows handle
Thanks !!
Version 1.5
2005-06-29 - Fixed a lot of bugs using tips from mails that I<EFBFBD>ve
being receiving for some time
BUG 1 - Loosing palette when assigning to TBitmap. fixed
BUG 2 - SetPixels and GetPixels worked only with
parameters in range 0..255. fixed
BUG 3 - Force type address off using directive
BUG 4 - TChunkzTXt contained an error
BUG 5 - MaxIdatSize was not working correctly (fixed thanks
to Gabriel Corneanu
BUG 6 - Corrected german translation (thanks to Mael Horz)
And the following improvements:
IMPROVE 1 - Create ImageHandleValue properties as public in
TChunkIHDR to get access to this handle
IMPROVE 2 - Using SetStretchBltMode to improve stretch quality
IMPROVE 3 - Scale is now working for alpha transparent images
IMPROVE 4 - GammaTable propery is now public to support an
article in the help file
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 and working
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: As always I<EFBFBD>m looking for bugs on the library. If
anyone has found one, please send me an email and
I will fix asap. Thanks for all the help and ideas
I'm receiving so far.}
{My email is : gustavo.daud@terra.com.br}
{Website link : http://pngdelphi.sourceforge.net}
{Gustavo Huffenbacher Daud}
unit frxpngimage;
interface
{$I frx.inc}
{Triggers avaliable (edit the fields bellow)}
{$TYPEDADDRESS OFF}
{$DEFINE UseDelphi} //Disable fat vcl units(perfect for 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
{$RANGECHECKS OFF} {$J+}
uses
Windows {$IFDEF UseDelphi}, Classes, Graphics, SysUtils{$ENDIF},
frxZlib, frxpnglang;
const
LibraryVersion = '1.564';
{$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);
EPNGInvalidNewSize = class(Exception);
EPNGInvalidSpec = 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
{Finds the first item with this class}
function FindChunk(ChunkClass: TChunkClass): TChunk;
{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;
TChunkpHYs = 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
{Inverse gamma table values}
InverseGamma: Array[Byte] of Byte;
procedure InitializeGamma;
private
{Canvas}
{$IFDEF UseDelphi}fCanvas: TCanvas;{$ENDIF}
{Filters to test to encode}
fFilters: TFilters;
{Compression level for ZLIB}
fCompressionLevel: TCompressionLevel;
{Maximum size for IDAT chunks}
fMaxIdatSize: Integer;
{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;
procedure GetPixelInfo(var LineSize, Offset: Cardinal);
{Returns linesize and byte offset for pixels}
procedure SetMaxIdatSize(const Value: Integer);
function GetAlphaScanline(const LineIndex: Integer): pByteArray;
function GetScanline(const LineIndex: Integer): Pointer;
{$IFDEF Store16bits}
function GetExtraScanline(const LineIndex: Integer): Pointer;
{$ENDIF}
function GetPixelInformation: TChunkpHYs;
function GetTransparencyMode: TPNGTransparencyMode;
function GetTransparentColor: TColor;
procedure SetTransparentColor(const Value: TColor);
{Returns the version}
function GetLibraryVersion: String;
protected
{Being created}
BeingCreated: Boolean;
{Returns / set the image palette}
function GetPalette: HPALETTE; {$IFDEF UseDelphi}override;{$ENDIF}
procedure SetPalette(Value: HPALETTE); {$IFDEF UseDelphi}override;{$ENDIF}
procedure DoSetPalette(Value: HPALETTE; const UpdateColors: Boolean);
{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;
{Draws using partial transparency}
procedure DrawPartialTrans(DC: HDC; Rect: TRect);
{$IFDEF UseDelphi}
{Returns if the image is transparent}
function GetTransparent: Boolean; override;
{$ENDIF}
{Returns a pixel}
function GetPixels(const X, Y: Integer): TColor; virtual;
procedure SetPixels(const X, Y: Integer; const Value: TColor); virtual;
public
{Gamma table array}
GammaTable: Array[Byte] of Byte;
{Resizes the PNG image}
procedure Resize(const CX, CY: Integer);
{Generates alpha information}
procedure CreateAlpha;
{Removes the image transparency}
procedure RemoveTransparency;
{Transparent color}
property TransparentColor: TColor read GetTransparentColor write
SetTransparentColor;
{Add text chunk, TChunkTEXT, TChunkzTXT}
procedure AddtEXt(const Keyword, Text: String);
procedure AddzTXt(const Keyword, Text: String);
{$IFDEF UseDelphi}
{Saves to clipboard format (thanks to Antoine Pottern)}
procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPalette); override;
procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPalette); override;
{$ENDIF}
{Calling errors}
procedure RaiseError(ExceptionClass: ExceptClass; Text: String);
{Returns a scanline from png}
property Scanline[const Index: Integer]: Pointer read GetScanline;
{$IFDEF Store16bits}
property ExtraScanline[const Index: Integer]: Pointer read GetExtraScanline;
{$ENDIF}
{Used to return pixel information}
function HasPixelInformation: Boolean;
property PixelInformation: TChunkpHYs read GetPixelInformation;
property AlphaScanline[const Index: Integer]: pByteArray read
GetAlphaScanline;
procedure DrawUsingPixelInformation(Canvas: TCanvas; Point: TPoint);
{Canvas}
{$IFDEF UseDelphi}property Canvas: TCanvas read fCanvas;{$ENDIF}
{Returns pointer to the header}
property Header: TChunkIHDR read GetHeader;
{Returns the transparency mode used by this png}
property TransparencyMode: TPNGTransparencyMode read GetTransparencyMode;
{Assigns from another object}
procedure Assign(Source: TPersistent);{$IFDEF UseDelphi}override;{$ENDIF}
{Assigns to another object}
procedure AssignTo(Dest: TPersistent);{$IFDEF UseDelphi}override;{$ENDIF}
{Assigns from a windows bitmap handle}
procedure AssignHandle(Handle: HBitmap; Transparent: Boolean;
TransparentColor: ColorRef);
{Draws the image into a canvas}
procedure Draw(ACanvas: TCanvas; const Rect: TRect);
{$IFDEF UseDelphi}override;{$ENDIF}
{Width and height properties}
property Width: Integer read GetWidth;
property Height: Integer read GetHeight;
{Returns if the image is interlaced}
property InterlaceMethod: TInterlaceMethod read fInterlaceMethod
write fInterlaceMethod;
{Filters to test to encode}
property Filters: TFilters read fFilters write fFilters;
{Maximum size for IDAT chunks, default and minimum is 65536}
property MaxIdatSize: Integer read fMaxIdatSize write SetMaxIdatSize;
{Property to return if the image is empty or not}
property Empty: Boolean read GetEmpty;
{Compression level}
property CompressionLevel: TCompressionLevel read fCompressionLevel
write fCompressionLevel;
{Access to the chunk list}
property Chunks: TPngList read fChunkList;
{Object being created and destroyed}
constructor Create; {$IFDEF UseDelphi}override;{$ENDIF}
constructor CreateBlank(ColorType, Bitdepth: Cardinal; cx, cy: Integer);
destructor Destroy; override;
{$IFNDEF UseDelphi}procedure LoadFromFile(const Filename: String);{$ENDIF}
{$IFNDEF UseDelphi}procedure SaveToFile(const Filename: String);{$ENDIF}
procedure LoadFromStream(Stream: TStream);
{$IFDEF UseDelphi}override;{$ENDIF}
procedure SaveToStream(Stream: TStream); {$IFDEF UseDelphi}override;{$ENDIF}
{Loading the image from resources}
procedure LoadFromResourceName(Instance: HInst; const Name: String);
procedure LoadFromResourceID(Instance: HInst; ResID: Integer);
{Access to the png pixels}
property Pixels[const X, Y: Integer]: TColor read GetPixels write SetPixels;
{Palette property}
{$IFNDEF UseDelphi}property Palette: HPalette read GetPalette write
SetPalette;{$ENDIF}
{Returns the version}
property Version: String read GetLibraryVersion;
end;
{Chunk name object}
TChunkName = Array[0..3] of Char;
{Global chunk object}
TChunk = class
private
{Contains data}
fData: Pointer;
fDataSize: Cardinal;
{Stores owner}
fOwner: TPngObject;
{Stores the chunk name}
fName: TChunkName;
{Returns pointer to the TChunkIHDR}
function GetHeader: TChunkIHDR;
{Used with property index}
function GetIndex: Integer;
{Should return chunk class/name}
class function GetName: String; virtual;
{Returns the chunk name}
function GetChunkName: String;
public
{Returns index from list}
property Index: Integer read GetIndex;
{Returns pointer to the TChunkIHDR}
property Header: TChunkIHDR read GetHeader;
{Resize the data}
procedure ResizeData(const NewSize: Cardinal);
{Returns data and size}
property Data: Pointer read fData;
property DataSize: Cardinal read fDataSize;
{Assigns from another TChunk}
procedure Assign(Source: TChunk); virtual;
{Returns owner}
property Owner: TPngObject read fOwner;
{Being destroyed/created}
constructor Create(Owner: TPngObject); virtual;
destructor Destroy; override;
{Returns chunk class/name}
property Name: String read GetChunkName;
{Loads the chunk from a stream}
function LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
Size: Integer): Boolean; virtual;
{Saves the chunk to a stream}
function SaveData(Stream: TStream): Boolean;
function SaveToStream(Stream: TStream): Boolean; virtual;
end;
{Chunk classes}
TChunkIEND = class(TChunk); {End chunk}
{IHDR data}
pIHDRData = ^TIHDRData;
TIHDRData = packed record
Width, Height: Cardinal;
BitDepth,
ColorType,
CompressionMethod,
FilterMethod,
InterlaceMethod: Byte;
end;
{Information header chunk}
TChunkIHDR = class(TChunk)
private
{Current image}
ImageHandle: HBitmap;
ImageDC: HDC;
ImagePalette: HPalette;
{Output windows bitmap}
HasPalette: Boolean;
BitmapInfo: TMaxBitmapInfo;
{Stores the image bytes}
{$IFDEF Store16bits}ExtraImageData: Pointer;{$ENDIF}
ImageData: pointer;
ImageAlpha: Pointer;
{Contains all the ihdr data}
IHDRData: TIHDRData;
protected
BytesPerRow: Integer;
{Creates a grayscale palette}
function CreateGrayscalePalette(Bitdepth: Integer): HPalette;
{Copies the palette to the Device Independent bitmap header}
procedure PaletteToDIB(Palette: HPalette);
{Resizes the image data to fill the color type, bit depth, }
{width and height parameters}
procedure PrepareImageData;
{Release allocated ImageData memory}
procedure FreeImageData;
public
{Access to ImageHandle}
property ImageHandleValue: HBitmap read ImageHandle;
{Properties}
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;
{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;
{Destructor/constructor}
constructor Create(Owner: TPngObject); override;
destructor Destroy; override;
{Assigns from another TChunk}
procedure Assign(Source: TChunk); override;
end;
{pHYs chunk}
pUnitType = ^TUnitType;
TUnitType = (utUnknown, utMeter);
TChunkpHYs = class(TChunk)
private
fPPUnitX, fPPUnitY: Cardinal;
fUnit: TUnitType;
public
{Returns the properties}
property PPUnitX: Cardinal read fPPUnitX write fPPUnitX;
property PPUnitY: Cardinal read fPPUnitY write fPPUnitY;
property UnitType: TUnitType read fUnit write fUnit;
{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;
{Gamma chunk}
TChunkgAMA = class(TChunk)
private
{Returns/sets the value for the gamma chunk}
function GetValue: Cardinal;
procedure SetValue(const Value: Cardinal);
public
{Returns/sets gamma value}
property Gamma: Cardinal read GetValue write SetValue;
{Loading the chunk from a stream}
function LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
Size: Integer): Boolean; override;
{Being created}
constructor Create(Owner: TPngObject); override;
{Assigns from another TChunk}
procedure Assign(Source: TChunk); override;
end;
{ZLIB Decompression extra information}
TZStreamRec2 = packed record
{From ZLIB}
ZLIB: TZStreamRec;
{Additional info}
Data: Pointer;
fStream : TStream;
end;
{Palette chunk}
TChunkPLTE = class(TChunk)
protected
{Number of items in the palette}
fCount: Integer;
private
{Contains the palette handle}
function GetPaletteItem(Index: Byte): TRGBQuad;
public
{Returns the color for each item in the palette}
property Item[Index: Byte]: TRGBQuad read GetPaletteItem;
{Returns the number of items in the palette}
property Count: Integer read fCount;
{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;
{Transparency information}
TChunktRNS = class(TChunk)
private
fBitTransparency: Boolean;
function GetTransparentColor: ColorRef;
{Returns the transparent color}
procedure SetTransparentColor(const Value: ColorRef);
public
{Palette values for transparency}
PaletteValues: Array[Byte] of Byte;
{Returns if it uses bit transparency}
property BitTransparency: Boolean read fBitTransparency;
{Returns the transparent color}
property TransparentColor: ColorRef read GetTransparentColor write
SetTransparentColor;
{Loads/saves the chunk from/to a stream}
function LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
Size: Integer): Boolean; override;
function SaveToStream(Stream: TStream): Boolean; override;
{Assigns from another TChunk}
procedure Assign(Source: TChunk); override;
end;
{Actual image information}
TChunkIDAT = class(TChunk)
private
{Holds another pointer to the TChunkIHDR}
Header: TChunkIHDR;
{Stores temporary image width and height}
ImageWidth, ImageHeight: Integer;
{Size in bytes of each line and offset}
Row_Bytes, Offset : Cardinal;
{Contains data for the lines}
Encode_Buffer: Array[0..5] of pByteArray;
Row_Buffer: Array[Boolean] of pByteArray;
{Variable to invert the Row_Buffer used}
RowUsed: Boolean;
{Ending position for the current IDAT chunk}
EndPos: Integer;
{Filter the current line}
procedure FilterRow;
{Filter to encode and returns the best filter}
function FilterToEncode: Byte;
{Reads ZLIB compressed data}
function IDATZlibRead(var ZLIBStream: TZStreamRec2; Buffer: Pointer;
Count: Integer; var EndPos: Integer; var crcfile: Cardinal): Integer;
{Compress and writes IDAT data}
procedure IDATZlibWrite(var ZLIBStream: TZStreamRec2; Buffer: Pointer;
const Length: Cardinal);
procedure FinishIDATZlib(var ZLIBStream: TZStreamRec2);
{Prepares the palette}
procedure PreparePalette;
protected
{Decode interlaced image}
procedure DecodeInterlacedAdam7(Stream: TStream;
var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal);
{Decode non interlaced imaged}
procedure DecodeNonInterlaced(Stream: TStream;
var ZLIBStream: TZStreamRec2; const Size: Integer;
var crcfile: Cardinal);
protected
{Encode non interlaced images}
procedure EncodeNonInterlaced(Stream: TStream;
var ZLIBStream: TZStreamRec2);
{Encode interlaced images}
procedure EncodeInterlacedAdam7(Stream: TStream;
var ZLIBStream: TZStreamRec2);
protected
{Memory copy methods to decode}
procedure CopyNonInterlacedRGB8(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyNonInterlacedRGB16(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyNonInterlacedPalette148(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyNonInterlacedPalette2(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyNonInterlacedGray2(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyNonInterlacedGrayscale16(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyNonInterlacedRGBAlpha8(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyNonInterlacedRGBAlpha16(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyNonInterlacedGrayscaleAlpha8(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyNonInterlacedGrayscaleAlpha16(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyInterlacedRGB8(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyInterlacedRGB16(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyInterlacedPalette148(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyInterlacedPalette2(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyInterlacedGray2(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyInterlacedGrayscale16(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyInterlacedRGBAlpha8(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyInterlacedRGBAlpha16(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyInterlacedGrayscaleAlpha8(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
procedure CopyInterlacedGrayscaleAlpha16(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
protected
{Memory copy methods to encode}
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
{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;
{Image last modification chunk}
TChunktIME = class(TChunk)
private
{Holds the variables}
fYear: Word;
fMonth, fDay, fHour, fMinute, fSecond: Byte;
public
{Returns/sets variables}
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;
{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;
{Textual data}
TChunktEXt = class(TChunk)
private
fKeyword, fText: String;
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);
{Get 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(TChunkpHYs);
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_VERSIONS, 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_VERSIONS, 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;
Buffer : Array[Byte] of Byte;
InflateRet: Integer;
begin
with StreamRec do
begin
{Initializes}
Result := True;
OutputSize := 0;
{Prepares the data to decompress}
FillChar(StreamRec, SizeOf(TZStreamRec), #0);
InflateInit_(StreamRec, ZLIB_VERSIONS, SIZEOF(TZStreamRec));
next_in := Input;
avail_in := InputSize;
{Decodes data}
repeat
{In case it needs an output buffer}
if (avail_out = 0) then
begin
next_out := @Buffer;
avail_out := SizeOf(Buffer);
end {if (avail_out = 0)};
{Decompress and put in output}
InflateRet := inflate(StreamRec, 0);
if (InflateRet = Z_STREAM_END) or (InflateRet = 0) then
begin
{Reallocates output buffer}
inc(OutputSize, total_out);
if Output = nil then
GetMem(Output, OutputSize) else ReallocMem(Output, OutputSize);
{Copies the new data}
CopyMemory(Ptr(Longint(Output) + OutputSize - total_out),
@Buffer, total_out);
end {if (InflateRet = Z_STREAM_END) or (InflateRet = 0)}
{Now tests for errors}
else if InflateRet < 0 then
begin
Result := False;
ErrorOutput := AnsiString(StreamRec.msg);
InflateEnd(StreamRec);
Exit;
end {if InflateRet < 0}
until InflateRet = Z_STREAM_END;
{Terminates decompression}
InflateEnd(StreamRec);
end {with StreamRec}
end;
{Compresses ZLIB into a memory address}
function CompressZLIB(Input: Pointer; InputSize, CompressionLevel: Integer;
var Output: Pointer; var OutputSize: Integer;
var ErrorOutput: String): Boolean;
var
StreamRec : TZStreamRec;
Buffer : Array[Byte] of Byte;
DeflateRet: Integer;
begin
with StreamRec do
begin
Result := True; {By default returns TRUE as everything might have gone ok}
OutputSize := 0; {Initialize}
{Prepares the data to compress}
FillChar(StreamRec, SizeOf(TZStreamRec), #0);
DeflateInit_(StreamRec, CompressionLevel,ZLIB_VERSIONS, SIZEOF(TZStreamRec));
next_in := Input;
avail_in := InputSize;
while avail_in > 0 do
begin
{When it needs new buffer to stores the compressed data}
if avail_out = 0 then
begin
{Restore buffer}
next_out := @Buffer;
avail_out := SizeOf(Buffer);
end {if avail_out = 0};
{Compresses}
DeflateRet := deflate(StreamRec, Z_FINISH);
if (DeflateRet = Z_STREAM_END) or (DeflateRet = 0) then
begin
{Updates the output memory}
inc(OutputSize, total_out);
if Output = nil then
GetMem(Output, OutputSize) else ReallocMem(Output, OutputSize);
{Copies the new data}
CopyMemory(Ptr(Longint(Output) + OutputSize - total_out),
@Buffer, total_out);
end {if (InflateRet = Z_STREAM_END) or (InflateRet = 0)}
{Now tests for errors}
else if DeflateRet < 0 then
begin
Result := False;
ErrorOutput := AnsiString(StreamRec.msg);
DeflateEnd(StreamRec);
Exit;
end {if InflateRet < 0}
end {while avail_in > 0};
{Finishes compressing}
DeflateEnd(StreamRec);
end {with StreamRec}
end;
{TPngPointerList implementation}
{Object being created}
constructor TPngPointerList.Create(AOwner: TPNGObject);
begin
inherited Create; {Let ancestor work}
{Holds owner}
fOwner := AOwner;
{Memory pointer not being used yet}
fMemory := nil;
{No items yet}
fCount := 0;
end;
{Removes value from the list}
function TPngPointerList.Remove(Value: Pointer): Pointer;
var
I, Position: Integer;
begin
{Gets item position}
Position := -1;
FOR I := 0 TO Count - 1 DO
if Value = Item[I] then Position := I;
{In case a match was found}
if Position >= 0 then
begin
Result := Item[Position]; {Returns pointer}
{Remove item and move memory}
Dec(fCount);
if Position < Integer(FCount) then
System.Move(fMemory^[Position + 1], fMemory^[Position],
(Integer(fCount) - Position) * SizeOf(Pointer));
end {if Position >= 0} else Result := nil
end;
{Add a new value in the list}
procedure TPngPointerList.Add(Value: Pointer);
begin
Count := Count + 1;
Item[Count - 1] := Value;
end;
{Object being destroyed}
destructor TPngPointerList.Destroy;
begin
{Release memory if needed}
if fMemory <> nil then
FreeMem(fMemory, fCount * sizeof(Pointer));
{Free things}
inherited Destroy;
end;
{Returns one item from the list}
function TPngPointerList.GetItem(Index: Cardinal): Pointer;
begin
if (Index <= Count - 1) then
Result := fMemory[Index]
else
{In case it's out of bounds}
Result := nil;
end;
{Inserts a new item in the list}
procedure TPngPointerList.Insert(Value: Pointer; Position: Cardinal);
begin
if (Position < Count) or (Count = 0) then
begin
{Increase item count}
SetSize(Count + 1);
{Move other pointers}
if Position < Count then
System.Move(fMemory^[Position], fMemory^[Position + 1],
(Count - Position - 1) * SizeOf(Pointer));
{Sets item}
Item[Position] := Value;
end;
end;
{Sets one item from the list}
procedure TPngPointerList.SetItem(Index: Cardinal; const Value: Pointer);
begin
{If index is in bounds, set value}
if (Index <= Count - 1) then
fMemory[Index] := Value
end;
{This method resizes the list}
procedure TPngPointerList.SetSize(const Size: Cardinal);
begin
{Sets the size}
if (fMemory = nil) and (Size > 0) then
GetMem(fMemory, Size * SIZEOF(Pointer))
else
if Size > 0 then {Only realloc if the new size is greater than 0}
ReallocMem(fMemory, Size * SIZEOF(Pointer))
else
{In case user is resize to 0 items}
begin
FreeMem(fMemory);
fMemory := nil;
end;
{Update count}
fCount := Size;
end;
{TPNGList implementation}
{Finds the first chunk of this class}
function TPNGList.FindChunk(ChunkClass: TChunkClass): TChunk;
var
i: Integer;
begin
Result := nil;
for i := 0 to Count - 1 do
if Item[i] is ChunkClass then
begin
Result := Item[i];
Break
end
end;
{Removes an item}
procedure TPNGList.RemoveChunk(Chunk: TChunk);
begin
Remove(Chunk);
Chunk.Free
end;
{Add a new item}
function TPNGList.Add(ChunkClass: TChunkClass): TChunk;
var
IHDR: TChunkIHDR;
IEND: TChunkIEND;
IDAT: TChunkIDAT;
PLTE: TChunkPLTE;
begin
Result := nil; {Default result}
{Adding these is not allowed}
if ((ChunkClass = TChunkIHDR) or (ChunkClass = TChunkIDAT) or
(ChunkClass = TChunkPLTE) or (ChunkClass = TChunkIEND)) and not
(Owner.BeingCreated) then
fOwner.RaiseError(EPngError, EPNGCannotAddChunkText)
{Two of these is not allowed}
else if ((ChunkClass = TChunkgAMA) and (ItemFromClass(TChunkgAMA) <> nil)) or
((ChunkClass = TChunktRNS) and (ItemFromClass(TChunktRNS) <> nil)) or
((ChunkClass = TChunkpHYs) and (ItemFromClass(TChunkpHYs) <> nil)) then
fOwner.RaiseError(EPngError, EPNGCannotAddChunkText)
{There must have an IEND and IHDR chunk}
else if ((ItemFromClass(TChunkIEND) = nil) or
(ItemFromClass(TChunkIHDR) = nil)) and not Owner.BeingCreated then
fOwner.RaiseError(EPngError, EPNGCannotAddInvalidImageText)
else
begin
{Get common chunks}
IHDR := ItemFromClass(TChunkIHDR) as TChunkIHDR;
IEND := ItemFromClass(TChunkIEND) as TChunkIEND;
{Create new chunk}
Result := ChunkClass.Create(Owner);
{Add to the list}
if (ChunkClass = TChunkgAMA) or (ChunkClass = TChunkpHYs) or
(ChunkClass = TChunkPLTE) then
Insert(Result, IHDR.Index + 1)
{Header and end}
else if (ChunkClass = TChunkIEND) then
Insert(Result, Count)
else if (ChunkClass = TChunkIHDR) then
Insert(Result, 0)
{Transparency chunk (fix by Ian Boyd)}
else if (ChunkClass = TChunktRNS) then
begin
{Transparecy chunk must be after PLTE; before IDAT}
IDAT := ItemFromClass(TChunkIDAT) as TChunkIDAT;
PLTE := ItemFromClass(TChunkPLTE) as TChunkPLTE;
if Assigned(PLTE) then
Insert(Result, PLTE.Index + 1)
else if Assigned(IDAT) then
Insert(Result, IDAT.Index)
else
Insert(Result, IHDR.Index + 1)
end
else {All other chunks}
Insert(Result, IEND.Index);
end {if}
end;
{Returns item from the list}
function TPNGList.GetItem(Index: Cardinal): TChunk;
begin
Result := inherited GetItem(Index);
end;
{Returns first item from the list using the class from parameter}
function TPNGList.ItemFromClass(ChunkClass: TChunkClass): TChunk;
var
i: Cardinal;
begin
Result := nil; {Initial result}
if Count = 0 then Exit;
FOR i := 0 TO Count - 1 DO
{Test if this item has the same class}
if Item[i] is ChunkClass then
begin
{Returns this item and exit}
Result := Item[i];
break;
end {if}
end;
{$IFNDEF UseDelphi}
{TStream implementation}
{Copies all from another stream}
function TStream.CopyFrom(Source: TStream; Count: Cardinal): Cardinal;
const
MaxBytes = $f000;
var
Buffer: PChar;
BufSize, N: Cardinal;
begin
{If count is zero, copy everything from Source}
if Count = 0 then
begin
Source.Seek(0, soFromBeginning);
Count := Source.Size;
end;
Result := Count; {Returns the number of bytes readed}
{Allocates memory}
if Count > MaxBytes then BufSize := MaxBytes else BufSize := Count;
GetMem(Buffer, BufSize);
{Copy memory}
while Count > 0 do
begin
if Count > BufSize then N := BufSize else N := Count;
Source.Read(Buffer^, N);
Write(Buffer^, N);
dec(Count, N);
end;
{Deallocates memory}
FreeMem(Buffer, BufSize);
end;
{Set current stream position}
procedure TStream.SetPosition(const Value: Longint);
begin
Seek(Value, soFromBeginning);
end;
{Returns position}
function TStream.GetPosition: Longint;
begin
Result := Seek(0, soFromCurrent);
end;
{Returns stream size}
function TStream.GetSize: Longint;
var
Pos: Cardinal;
begin
Pos := Seek(0, soFromCurrent);
Result := Seek(0, soFromEnd);
Seek(Pos, soFromBeginning);
end;
{TFileStream implementation}
{Filestream object being created}
constructor TFileStream.Create(Filename: String; Mode: TFileStreamModeSet);
{Makes file mode}
function OpenMode: DWORD;
begin
Result := 0;
if fsmRead in Mode then Result := GENERIC_READ;
if (fsmWrite in Mode) or (fsmCreate in Mode) then
Result := Result OR GENERIC_WRITE;
end;
const
IsCreate: Array[Boolean] of Integer = (OPEN_ALWAYS, CREATE_ALWAYS);
begin
{Call ancestor}
inherited Create;
{Create handle}
fHandle := CreateFile(PChar(Filename), OpenMode, FILE_SHARE_READ or
FILE_SHARE_WRITE, nil, IsCreate[fsmCreate in Mode], 0, 0);
{Store mode}
FileMode := Mode;
end;
{Filestream object being destroyed}
destructor TFileStream.Destroy;
begin
{Terminates file and close}
if FileMode = [fsmWrite] then
SetEndOfFile(fHandle);
CloseHandle(fHandle);
{Call ancestor}
inherited Destroy;
end;
{Writes data to the file}
function TFileStream.Write(const Buffer; Count: Longint): Cardinal;
begin
if not WriteFile(fHandle, Buffer, Count, Result, nil) then
Result := 0;
end;
{Reads data from the file}
function TFileStream.Read(var Buffer; Count: Longint): Cardinal;
begin
if not ReadFile(fHandle, Buffer, Count, Result, nil) then
Result := 0;
end;
{Seeks the file position}
function TFileStream.Seek(Offset: Integer; Origin: Word): Longint;
begin
Result := SetFilePointer(fHandle, Offset, nil, Origin);
end;
{Sets the size of the file}
procedure TFileStream.SetSize(const Value: Longint);
begin
Seek(Value, soFromBeginning);
SetEndOfFile(fHandle);
end;
{TResourceStream implementation}
{Creates the resource stream}
constructor TResourceStream.Create(Instance: HInst; const ResName: String;
ResType: PChar);
var
ResID: HRSRC;
ResGlobal: HGlobal;
begin
{Obtains the resource ID}
ResID := FindResource(hInstance, PChar(ResName), RT_RCDATA);
if ResID = 0 then raise EPNGError.Create('');
{Obtains memory and size}
ResGlobal := LoadResource(hInstance, ResID);
Size := SizeOfResource(hInstance, ResID);
Memory := LockResource(ResGlobal);
if (ResGlobal = 0) or (Memory = nil) then EPNGError.Create('');
end;
{Setting resource stream size is not supported}
procedure TResourceStream.SetSize(const Value: Integer);
begin
end;
{Writing into a resource stream is not supported}
function TResourceStream.Write(const Buffer; Count: Integer): Cardinal;
begin
Result := 0;
end;
{Reads data from the stream}
function TResourceStream.Read(var Buffer; Count: Integer): Cardinal;
begin
//Returns data
CopyMemory(@Buffer, Ptr(Longint(Memory) + Position), Count);
//Update position
inc(Position, Count);
//Returns
Result := Count;
end;
{Seeks data}
function TResourceStream.Seek(Offset: Integer; Origin: Word): Longint;
begin
{Move depending on the origin}
case Origin of
soFromBeginning: Position := Offset;
soFromCurrent: inc(Position, Offset);
soFromEnd: Position := Size + Offset;
end;
{Returns the current position}
Result := Position;
end;
{$ENDIF}
{TChunk implementation}
{Resizes the data}
procedure TChunk.ResizeData(const NewSize: Cardinal);
begin
fDataSize := NewSize;
ReallocMem(fData, NewSize + 1);
end;
{Returns index from list}
function TChunk.GetIndex: Integer;
var
i: Integer;
begin
Result := -1; {Avoiding warnings}
{Searches in the list}
FOR i := 0 TO Owner.Chunks.Count - 1 DO
if Owner.Chunks.Item[i] = Self then
begin
{Found match}
Result := i;
exit;
end {for i}
end;
{Returns pointer to the TChunkIHDR}
function TChunk.GetHeader: TChunkIHDR;
begin
Result := Owner.Chunks.Item[0] as TChunkIHDR;
end;
{Assigns from another TChunk}
procedure TChunk.Assign(Source: TChunk);
begin
{Copy properties}
fName := Source.fName;
{Set data size and realloc}
ResizeData(Source.fDataSize);
{Copy data (if there's any)}
if fDataSize > 0 then CopyMemory(fData, Source.fData, fDataSize);
end;
{Chunk being created}
constructor TChunk.Create(Owner: TPngObject);
var
ChunkName: String;
begin
{Ancestor create}
inherited Create;
{If it's a registered class, set the chunk name based on the class}
{name. For instance, if the class name is TChunkgAMA, the GAMA part}
{will become the chunk name}
ChunkName := Copy(ClassName, Length('TChunk') + 1, Length(ClassName));
if Length(ChunkName) = 4 then CopyMemory(@fName[0], @ChunkName[1], 4);
{Initialize data holder}
GetMem(fData, 1);
fDataSize := 0;
{Record owner}
fOwner := Owner;
end;
{Chunk being destroyed}
destructor TChunk.Destroy;
begin
{Free data holder}
FreeMem(fData, fDataSize + 1);
{Let ancestor destroy}
inherited Destroy;
end;
{Returns the chunk name 1}
function TChunk.GetChunkName: String;
begin
Result := fName
end;
{Returns the chunk name 2}
class function TChunk.GetName: String;
begin
{For avoid writing GetName for each TChunk descendent, by default for}
{classes which don't declare GetName, it will look for the class name}
{to extract the chunk kind. Example, if the class name is TChunkIEND }
{this method extracts and returns IEND}
Result := Copy(ClassName, Length('TChunk') + 1, Length(ClassName));
end;
{Saves the data to the stream}
function TChunk.SaveData(Stream: TStream): Boolean;
var
ChunkSize, ChunkCRC: Cardinal;
begin
{First, write the size for the following data in the chunk}
ChunkSize := ByteSwap(DataSize);
Stream.Write(ChunkSize, 4);
{The chunk name}
Stream.Write(fName, 4);
{If there is data for the chunk, write it}
if DataSize > 0 then Stream.Write(Data^, DataSize);
{Calculates and write CRC}
ChunkCRC := update_crc($ffffffff, @fName[0], 4);
ChunkCRC := Byteswap(update_crc(ChunkCRC, Data, DataSize) xor $ffffffff);
Stream.Write(ChunkCRC, 4);
{Returns that everything went ok}
Result := TRUE;
end;
{Saves the chunk to the stream}
function TChunk.SaveToStream(Stream: TStream): Boolean;
begin
Result := SaveData(Stream)
end;
{Loads the chunk from a stream}
function TChunk.LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
Size: Integer): Boolean;
var
CheckCRC: Cardinal;
{$IFDEF CheckCRC}RightCRC: Cardinal;{$ENDIF}
begin
{Copies data from source}
ResizeData(Size);
if Size > 0 then Stream.Read(fData^, Size);
{Reads CRC}
Stream.Read(CheckCRC, 4);
CheckCrc := ByteSwap(CheckCRC);
{Check if crc readed is valid}
{$IFDEF CheckCRC}
RightCRC := update_crc($ffffffff, @ChunkName[0], 4);
RightCRC := update_crc(RightCRC, fData, Size) xor $ffffffff;
Result := RightCRC = CheckCrc;
{Handle CRC error}
if not Result then
begin
{In case it coult not load chunk}
Owner.RaiseError(EPngInvalidCRC, EPngInvalidCRCText);
exit;
end
{$ELSE}Result := TRUE; {$ENDIF}
end;
{TChunktIME implementation}
{Chunk being loaded from a stream}
function TChunktIME.LoadFromStream(Stream: TStream;
const ChunkName: TChunkName; Size: Integer): Boolean;
begin
{Let ancestor load the data}
Result := inherited LoadFromStream(Stream, ChunkName, Size);
if not Result or (Size <> 7) then exit; {Size must be 7}
{Reads data}
fYear := ((pByte(Longint(Data) )^) * 256)+ (pByte(Longint(Data) + 1)^);
fMonth := pByte(Longint(Data) + 2)^;
fDay := pByte(Longint(Data) + 3)^;
fHour := pByte(Longint(Data) + 4)^;
fMinute := pByte(Longint(Data) + 5)^;
fSecond := pByte(Longint(Data) + 6)^;
end;
{Assigns from another TChunk}
procedure TChunktIME.Assign(Source: TChunk);
begin
fYear := TChunktIME(Source).fYear;
fMonth := TChunktIME(Source).fMonth;
fDay := TChunktIME(Source).fDay;
fHour := TChunktIME(Source).fHour;
fMinute := TChunktIME(Source).fMinute;
fSecond := TChunktIME(Source).fSecond;
end;
{Saving the chunk to a stream}
function TChunktIME.SaveToStream(Stream: TStream): Boolean;
begin
{Update data}
ResizeData(7); {Make sure the size is 7}
pWord(Data)^ := ByteSwap16(Year);
pByte(Longint(Data) + 2)^ := Month;
pByte(Longint(Data) + 3)^ := Day;
pByte(Longint(Data) + 4)^ := Hour;
pByte(Longint(Data) + 5)^ := Minute;
pByte(Longint(Data) + 6)^ := Second;
{Let inherited save data}
Result := inherited SaveToStream(Stream);
end;
{TChunkztXt implementation}
{Loading the chunk from a stream}
function TChunkzTXt.LoadFromStream(Stream: TStream;
const ChunkName: TChunkName; Size: Integer): Boolean;
var
ErrorOutput: String;
CompressionMethod: Byte;
Output: Pointer;
OutputSize: Integer;
begin
{Load data from stream and validate}
Result := inherited LoadFromStream(Stream, ChunkName, Size);
if not Result or (Size < 4) then exit;
fKeyword := PChar(Data); {Get keyword and compression method bellow}
if Longint(fKeyword) = 0 then
CompressionMethod := pByte(Data)^
else
CompressionMethod := pByte(Longint(fKeyword) + Length(fKeyword))^;
fText := '';
{In case the compression is 0 (only one accepted by specs), reads it}
if CompressionMethod = 0 then
begin
Output := nil;
if DecompressZLIB(PChar(Longint(Data) + Length(fKeyword) + 2),
Size - Length(fKeyword) - 2, Output, OutputSize, ErrorOutput) then
begin
SetLength(fText, OutputSize);
CopyMemory(@fText[1], Output, OutputSize);
end {if DecompressZLIB(...};
FreeMem(Output);
end {if CompressionMethod = 0}
end;
{Saving the chunk to a stream}
function TChunkztXt.SaveToStream(Stream: TStream): Boolean;
var
Output: Pointer;
OutputSize: Integer;
ErrorOutput: String;
begin
Output := nil; {Initializes output}
if fText = '' then fText := ' ';
{Compresses the data}
if CompressZLIB(@fText[1], Length(fText), Owner.CompressionLevel, Output,
OutputSize, ErrorOutput) then
begin
{Size is length from keyword, plus a null character to divide}
{plus the compression method, plus the length of the text (zlib compressed)}
ResizeData(Length(fKeyword) + 2 + OutputSize);
Fillchar(Data^, DataSize, #0);
{Copies the keyword data}
if Keyword <> '' then
CopyMemory(Data, @fKeyword[1], Length(Keyword));
{Compression method 0 (inflate/deflate)}
pByte(Ptr(Longint(Data) + Length(Keyword) + 1))^ := 0;
if OutputSize > 0 then
CopyMemory(Ptr(Longint(Data) + Length(Keyword) + 2), Output, OutputSize);
{Let ancestor calculate crc and save}
Result := SaveData(Stream);
end {if CompressZLIB(...} else Result := False;
{Frees output}
if Output <> nil then FreeMem(Output)
end;
{TChunktEXt implementation}
{Assigns from another text chunk}
procedure TChunktEXt.Assign(Source: TChunk);
begin
fKeyword := TChunktEXt(Source).fKeyword;
fText := TChunktEXt(Source).fText;
end;
{Loading the chunk from a stream}
function TChunktEXt.LoadFromStream(Stream: TStream;
const ChunkName: TChunkName; Size: Integer): Boolean;
begin
{Load data from stream and validate}
Result := inherited LoadFromStream(Stream, ChunkName, Size);
if not Result or (Size < 3) then exit;
{Get text}
fKeyword := PChar(Data);
SetLength(fText, Size - Length(fKeyword) - 1);
CopyMemory(@fText[1], Ptr(Longint(Data) + Length(fKeyword) + 1),
Length(fText));
end;
{Saving the chunk to a stream}
function TChunktEXt.SaveToStream(Stream: TStream): Boolean;
begin
{Size is length from keyword, plus a null character to divide}
{plus the length of the text}
ResizeData(Length(fKeyword) + 1 + Length(fText));
Fillchar(Data^, DataSize, #0);
{Copy data}
if Keyword <> '' then
CopyMemory(Data, @fKeyword[1], Length(Keyword));
if Text <> '' then
CopyMemory(Ptr(Longint(Data) + Length(Keyword) + 1), @fText[1],
Length(Text));
{Let ancestor calculate crc and save}
Result := inherited SaveToStream(Stream);
end;
{TChunkIHDR implementation}
{Chunk being created}
constructor TChunkIHDR.Create(Owner: TPngObject);
begin
{Prepare pointers}
ImageHandle := 0;
ImagePalette := 0;
ImageDC := 0;
{Call inherited}
inherited Create(Owner);
end;
{Chunk being destroyed}
destructor TChunkIHDR.Destroy;
begin
{Free memory}
FreeImageData();
{Calls TChunk destroy}
inherited Destroy;
end;
{Copies the palette}
procedure CopyPalette(Source: HPALETTE; Destination: HPALETTE);
var
PaletteSize: Integer;
Entries: Array[Byte] of TPaletteEntry;
begin
PaletteSize := 0;
if GetObject(Source, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;
if PaletteSize = 0 then Exit;
ResizePalette(Destination, PaletteSize);
GetPaletteEntries(Source, 0, PaletteSize, Entries);
SetPaletteEntries(Destination, 0, PaletteSize, Entries);
end;
{Assigns from another IHDR chunk}
procedure TChunkIHDR.Assign(Source: TChunk);
begin
{Copy the IHDR data}
if Source is TChunkIHDR then
begin
{Copy IHDR values}
IHDRData := TChunkIHDR(Source).IHDRData;
{Prepare to hold data by filling BitmapInfo structure and}
{resizing ImageData and ImageAlpha memory allocations}
PrepareImageData();
{Copy image data}
CopyMemory(ImageData, TChunkIHDR(Source).ImageData,
BytesPerRow * Integer(Height));
CopyMemory(ImageAlpha, TChunkIHDR(Source).ImageAlpha,
Integer(Width) * Integer(Height));
{Copy palette colors}
BitmapInfo.bmiColors := TChunkIHDR(Source).BitmapInfo.bmiColors;
{Copy palette also}
CopyPalette(TChunkIHDR(Source).ImagePalette, ImagePalette);
end
else
Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText);
end;
{Release allocated image data}
procedure TChunkIHDR.FreeImageData;
begin
{Free old image data}
if ImageHandle <> 0 then DeleteObject(ImageHandle);
if ImageDC <> 0 then DeleteDC(ImageDC);
if ImageAlpha <> nil then FreeMem(ImageAlpha);
if ImagePalette <> 0 then DeleteObject(ImagePalette);
{$IFDEF Store16bits}
if ExtraImageData <> nil then FreeMem(ExtraImageData);
{$ENDIF}
ImageHandle := 0; ImageDC := 0; ImageAlpha := nil; ImageData := nil;
ImagePalette := 0; ExtraImageData := nil;
end;
{Chunk being loaded from a stream}
function TChunkIHDR.LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
Size: Integer): Boolean;
begin
{Let TChunk load it}
Result := inherited LoadFromStream(Stream, ChunkName, Size);
if not Result then Exit;
{Now check values}
{Note: It's recommended by png specification to make sure that the size}
{must be 13 bytes to be valid, but some images with 14 bytes were found}
{which could be loaded by internet explorer and other tools}
if (fDataSize < SIZEOF(TIHdrData)) then
begin
{Ihdr must always have at least 13 bytes}
Result := False;
Owner.RaiseError(EPNGInvalidIHDR, EPNGInvalidIHDRText);
exit;
end;
{Everything ok, reads IHDR}
IHDRData := pIHDRData(fData)^;
IHDRData.Width := ByteSwap(IHDRData.Width);
IHDRData.Height := ByteSwap(IHDRData.Height);
{The width and height must not be larger than 65535 pixels}
if (IHDRData.Width > High(Word)) or (IHDRData.Height > High(Word)) then
begin
Result := False;
Owner.RaiseError(EPNGSizeExceeds, EPNGSizeExceedsText);
exit;
end {if IHDRData.Width > High(Word)};
{Compression method must be 0 (inflate/deflate)}
if (IHDRData.CompressionMethod <> 0) then
begin
Result := False;
Owner.RaiseError(EPNGUnknownCompression, EPNGUnknownCompressionText);
exit;
end;
{Interlace must be either 0 (none) or 7 (adam7)}
if (IHDRData.InterlaceMethod <> 0) and (IHDRData.InterlaceMethod <> 1) then
begin
Result := False;
Owner.RaiseError(EPNGUnknownInterlace, EPNGUnknownInterlaceText);
exit;
end;
{Updates owner properties}
Owner.InterlaceMethod := TInterlaceMethod(IHDRData.InterlaceMethod);
{Prepares data to hold image}
PrepareImageData();
end;
{Saving the IHDR chunk to a stream}
function TChunkIHDR.SaveToStream(Stream: TStream): Boolean;
begin
{Ignore 2 bits images}
if BitDepth = 2 then BitDepth := 4;
{It needs to do is update the data with the IHDR data}
{structure containing the write values}
ResizeData(SizeOf(TIHDRData));
pIHDRData(fData)^ := IHDRData;
{..byteswap 4 byte types}
pIHDRData(fData)^.Width := ByteSwap(pIHDRData(fData)^.Width);
pIHDRData(fData)^.Height := ByteSwap(pIHDRData(fData)^.Height);
{..update interlace method}
pIHDRData(fData)^.InterlaceMethod := Byte(Owner.InterlaceMethod);
{..and then let the ancestor SaveToStream do the hard work}
Result := inherited SaveToStream(Stream);
end;
{Creates a grayscale palette}
function TChunkIHDR.CreateGrayscalePalette(Bitdepth: Integer): HPalette;
var
j: Integer;
palEntries: TMaxLogPalette;
begin
{Prepares and fills the strucutre}
if Bitdepth = 16 then Bitdepth := 8;
fillchar(palEntries, sizeof(palEntries), 0);
palEntries.palVersion := $300;
palEntries.palNumEntries := 1 shl Bitdepth;
{Fill it with grayscale colors}
for j := 0 to palEntries.palNumEntries - 1 do
begin
palEntries.palPalEntry[j].peRed :=
fOwner.GammaTable[MulDiv(j, 255, palEntries.palNumEntries - 1)];
palEntries.palPalEntry[j].peGreen := palEntries.palPalEntry[j].peRed;
palEntries.palPalEntry[j].peBlue := palEntries.palPalEntry[j].peRed;
end;
{Creates and returns the palette}
Result := CreatePalette(pLogPalette(@palEntries)^);
end;
{Copies the palette to the Device Independent bitmap header}
procedure TChunkIHDR.PaletteToDIB(Palette: HPalette);
var
j: Integer;
palEntries: TMaxLogPalette;
begin
{Copy colors}
Fillchar(palEntries, sizeof(palEntries), #0);
BitmapInfo.bmiHeader.biClrUsed := GetPaletteEntries(Palette, 0, 256, palEntries.palPalEntry[0]);
for j := 0 to BitmapInfo.bmiHeader.biClrUsed - 1 do
begin
BitmapInfo.bmiColors[j].rgbBlue := palEntries.palPalEntry[j].peBlue;
BitmapInfo.bmiColors[j].rgbRed := palEntries.palPalEntry[j].peRed;
BitmapInfo.bmiColors[j].rgbGreen := palEntries.palPalEntry[j].peGreen;
end;
end;
{Resizes the image data to fill the color type, bit depth, }
{width and height parameters}
procedure TChunkIHDR.PrepareImageData();
{Set the bitmap info}
procedure SetInfo(const Bitdepth: Integer; const Palette: Boolean);
begin
{Copy if the bitmap contain palette entries}
HasPalette := Palette;
{Fill the strucutre}
with BitmapInfo.bmiHeader do
begin
biSize := sizeof(TBitmapInfoHeader);
biHeight := Height;
biWidth := Width;
biPlanes := 1;
biBitCount := BitDepth;
biCompression := BI_RGB;
end {with BitmapInfo.bmiHeader}
end;
begin
{Prepare bitmap info header}
Fillchar(BitmapInfo, sizeof(TMaxBitmapInfo), #0);
{Release old image data}
FreeImageData();
{Obtain number of bits for each pixel}
case ColorType of
COLOR_GRAYSCALE, COLOR_PALETTE, COLOR_GRAYSCALEALPHA:
case BitDepth of
{These are supported by windows}
1, 4, 8: SetInfo(BitDepth, TRUE);
{2 bits for each pixel is not supported by windows bitmap}
2 : SetInfo(4, TRUE);
{Also 16 bits (2 bytes) for each pixel is not supported}
{and should be transormed into a 8 bit grayscale}
16 : SetInfo(8, TRUE);
end;
{Only 1 byte (8 bits) is supported}
COLOR_RGB, COLOR_RGBALPHA: SetInfo(24, FALSE);
end {case ColorType};
{Number of bytes for each scanline}
BytesPerRow := (((BitmapInfo.bmiHeader.biBitCount * Width) + 31)
and not 31) div 8;
{Build array for alpha information, if necessary}
if (ColorType = COLOR_RGBALPHA) or (ColorType = COLOR_GRAYSCALEALPHA) then
begin
GetMem(ImageAlpha, Integer(Width) * Integer(Height));
FillChar(ImageAlpha^, Integer(Width) * Integer(Height), #0);
end;
{Build array for extra byte information}
{$IFDEF Store16bits}
if (BitDepth = 16) then
begin
GetMem(ExtraImageData, BytesPerRow * Integer(Height));
FillChar(ExtraImageData^, BytesPerRow * Integer(Height), #0);
end;
{$ENDIF}
{Creates the image to hold the data, CreateDIBSection does a better}
{work in allocating necessary memory}
ImageDC := CreateCompatibleDC(0);
{$IFDEF UseDelphi}Self.Owner.Canvas.Handle := ImageDC;{$ENDIF}
{In case it is a palette image, create the palette}
if HasPalette then
begin
{Create a standard palette}
if ColorType = COLOR_PALETTE then
ImagePalette := CreateHalfTonePalette(ImageDC)
else
ImagePalette := CreateGrayscalePalette(Bitdepth);
ResizePalette(ImagePalette, 1 shl BitmapInfo.bmiHeader.biBitCount);
BitmapInfo.bmiHeader.biClrUsed := 1 shl BitmapInfo.bmiHeader.biBitCount;
SelectPalette(ImageDC, ImagePalette, False);
RealizePalette(ImageDC);
PaletteTODIB(ImagePalette);
end;
{Create the device independent bitmap}
ImageHandle := CreateDIBSection(ImageDC, pBitmapInfo(@BitmapInfo)^,
DIB_RGB_COLORS, ImageData, 0, 0);
SelectObject(ImageDC, ImageHandle);
{Build array and allocate bytes for each row}
fillchar(ImageData^, BytesPerRow * Integer(Height), 0);
end;
{TChunktRNS implementation}
{$IFNDEF UseDelphi}
function CompareMem(P1, P2: pByte; const Size: Integer): Boolean;
var i: Integer;
begin
Result := True;
for i := 1 to Size do
begin
if P1^ <> P2^ then Result := False;
inc(P1); inc(P2);
end {for i}
end;
{$ENDIF}
{Sets the transpararent color}
procedure TChunktRNS.SetTransparentColor(const Value: ColorRef);
var
i: Byte;
LookColor: TRGBQuad;
begin
{Clears the palette values}
Fillchar(PaletteValues, SizeOf(PaletteValues), #0);
{Sets that it uses bit transparency}
fBitTransparency := True;
{Depends on the color type}
with Header do
case ColorType of
COLOR_GRAYSCALE:
begin
Self.ResizeData(2);
pWord(@PaletteValues[0])^ := ByteSwap16(GetRValue(Value));
end;
COLOR_RGB:
begin
Self.ResizeData(6);
pWord(@PaletteValues[0])^ := ByteSwap16(GetRValue(Value));
pWord(@PaletteValues[2])^ := ByteSwap16(GetGValue(Value));
pWord(@PaletteValues[4])^ := ByteSwap16(GetBValue(Value));
end;
COLOR_PALETTE:
begin
{Creates a RGBQuad to search for the color}
LookColor.rgbRed := GetRValue(Value);
LookColor.rgbGreen := GetGValue(Value);
LookColor.rgbBlue := GetBValue(Value);
{Look in the table for the entry}
for i := 0 to BitmapInfo.bmiHeader.biClrUsed - 1 do
if CompareMem(@BitmapInfo.bmiColors[i], @LookColor, 3) then
Break;
{Fill the transparency table}
Fillchar(PaletteValues, i, 255);
Self.ResizeData(i + 1)
end
end {case / with};
end;
{Returns the transparent color for the image}
function TChunktRNS.GetTransparentColor: ColorRef;
var
PaletteChunk: TChunkPLTE;
i: Integer;
Value: Byte;
begin
Result := 0; {Default: Unknown transparent color}
{Depends on the color type}
with Header do
case ColorType of
COLOR_GRAYSCALE:
begin
Value := BitmapInfo.bmiColors[PaletteValues[1]].rgbRed;
Result := RGB(Value, Value, Value);
end;
COLOR_RGB:
Result := RGB(fOwner.GammaTable[PaletteValues[1]],
fOwner.GammaTable[PaletteValues[3]],
fOwner.GammaTable[PaletteValues[5]]);
COLOR_PALETTE:
begin
{Obtains the palette chunk}
PaletteChunk := Owner.Chunks.ItemFromClass(TChunkPLTE) as TChunkPLTE;
{Looks for an entry with 0 transparency meaning that it is the}
{full transparent entry}
for i := 0 to Self.DataSize - 1 do
if PaletteValues[i] = 0 then
with PaletteChunk.GetPaletteItem(i) do
begin
Result := RGB(rgbRed, rgbGreen, rgbBlue);
break
end
end {COLOR_PALETTE}
end {case Header.ColorType};
end;
{Saving the chunk to a stream}
function TChunktRNS.SaveToStream(Stream: TStream): Boolean;
begin
{Copy palette into data buffer}
if DataSize <= 256 then
CopyMemory(fData, @PaletteValues[0], DataSize);
Result := inherited SaveToStream(Stream);
end;
{Assigns from another chunk}
procedure TChunktRNS.Assign(Source: TChunk);
begin
CopyMemory(@PaletteValues[0], @TChunkTrns(Source).PaletteValues[0], 256);
fBitTransparency := TChunkTrns(Source).fBitTransparency;
inherited Assign(Source);
end;
{Loads the chunk from a stream}
function TChunktRNS.LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
Size: Integer): Boolean;
var
i, Differ255: Integer;
begin
{Let inherited load}
Result := inherited LoadFromStream(Stream, ChunkName, Size);
if not Result then Exit;
{Make sure size is correct}
if Size > 256 then Owner.RaiseError(EPNGInvalidPalette,
EPNGInvalidPaletteText);
{The unset items should have value 255}
Fillchar(PaletteValues[0], 256, 255);
{Copy the other values}
CopyMemory(@PaletteValues[0], fData, Size);
{Create the mask if needed}
case Header.ColorType of
{Mask for grayscale and RGB}
COLOR_RGB, COLOR_GRAYSCALE: fBitTransparency := True;
COLOR_PALETTE:
begin
Differ255 := 0; {Count the entries with a value different from 255}
{Tests if it uses bit transparency}
for i := 0 to Size - 1 do
if PaletteValues[i] <> 255 then inc(Differ255);
{If it has one value different from 255 it is a bit transparency}
fBitTransparency := (Differ255 = 1);
end {COLOR_PALETTE}
end {case Header.ColorType};
end;
{Prepares the image palette}
procedure TChunkIDAT.PreparePalette;
var
Entries: Word;
j : Integer;
palEntries: TMaxLogPalette;
begin
{In case the image uses grayscale, build a grayscale palette}
with Header do
if (ColorType = COLOR_GRAYSCALE) or (ColorType = COLOR_GRAYSCALEALPHA) then
begin
{Calculate total number of palette entries}
Entries := (1 shl Byte(BitmapInfo.bmiHeader.biBitCount));
Fillchar(palEntries, sizeof(palEntries), #0);
palEntries.palVersion := $300;
palEntries.palNumEntries := Entries;
FOR j := 0 TO Entries - 1 DO
with palEntries.palPalEntry[j] do
begin
{Calculate each palette entry}
peRed := fOwner.GammaTable[MulDiv(j, 255, Entries - 1)];
peGreen := peRed;
peBlue := peRed;
end {with BitmapInfo.bmiColors[j]};
Owner.SetPalette(CreatePalette(pLogPalette(@palEntries)^));
end {if ColorType = COLOR_GRAYSCALE..., with Header}
end;
{Reads from ZLIB}
function TChunkIDAT.IDATZlibRead(var ZLIBStream: TZStreamRec2;
Buffer: Pointer; Count: Integer; var EndPos: Integer;
var crcfile: Cardinal): Integer;
var
ProcResult : Integer;
IDATHeader : Array[0..3] of char;
IDATCRC : Cardinal;
begin
{Uses internal record pointed by ZLIBStream to gather information}
with ZLIBStream, ZLIBStream.zlib do
begin
{Set the buffer the zlib will read into}
next_out := Buffer;
avail_out := Count;
{Decode until it reach the Count variable}
while avail_out > 0 do
begin
{In case it needs more data and it's in the end of a IDAT chunk,}
{it means that there are more IDAT chunks}
if (fStream.Position = EndPos) and (avail_out > 0) and
(avail_in = 0) then
begin
{End this chunk by reading and testing the crc value}
fStream.Read(IDATCRC, 4);
{$IFDEF CheckCRC}
if crcfile xor $ffffffff <> Cardinal(ByteSwap(IDATCRC)) then
begin
Result := -1;
Owner.RaiseError(EPNGInvalidCRC, EPNGInvalidCRCText);
exit;
end;
{$ENDIF}
{Start reading the next chunk}
fStream.Read(EndPos, 4); {Reads next chunk size}
fStream.Read(IDATHeader[0], 4); {Next chunk header}
{It must be a IDAT chunk since image data is required and PNG}
{specification says that multiple IDAT chunks must be consecutive}
if IDATHeader <> 'IDAT' then
begin
Owner.RaiseError(EPNGMissingMultipleIDAT, EPNGMissingMultipleIDATText);
result := -1;
exit;
end;
{Calculate chunk name part of the crc}
{$IFDEF CheckCRC}
crcfile := update_crc($ffffffff, @IDATHeader[0], 4);
{$ENDIF}
EndPos := fStream.Position + ByteSwap(EndPos);
end;
{In case it needs compressed data to read from}
if avail_in = 0 then
begin
{In case it's trying to read more than it is avaliable}
if fStream.Position + ZLIBAllocate > EndPos then
avail_in := fStream.Read(Data^, EndPos - fStream.Position)
else
avail_in := fStream.Read(Data^, ZLIBAllocate);
{Update crc}
{$IFDEF CheckCRC}
crcfile := update_crc(crcfile, Data, avail_in);
{$ENDIF}
{In case there is no more compressed data to read from}
if avail_in = 0 then
begin
Result := Count - avail_out;
Exit;
end;
{Set next buffer to read and record current position}
next_in := Data;
end {if avail_in = 0};
ProcResult := inflate(zlib, 0);
{In case the result was not sucessfull}
if (ProcResult < 0) then
begin
Result := -1;
Owner.RaiseError(EPNGZLIBError,
EPNGZLIBErrorText + zliberrors[procresult]);
exit;
end;
end {while avail_out > 0};
end {with};
{If everything gone ok, it returns the count bytes}
Result := Count;
end;
{TChunkIDAT implementation}
const
{Adam 7 interlacing values}
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);
{Copy interlaced images with 1 byte for R, G, B}
procedure TChunkIDAT.CopyInterlacedRGB8(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Dest := pChar(Longint(Dest) + Col * 3);
repeat
{Copy this row}
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
{Move to next column}
inc(Src, 3);
inc(Dest, ColumnIncrement[Pass] * 3 - 3);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Copy interlaced images with 2 bytes for R, G, B}
procedure TChunkIDAT.CopyInterlacedRGB16(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Dest := pChar(Longint(Dest) + Col * 3);
repeat
{Copy this row}
Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest);
Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
{$IFDEF Store16bits}
{Copy extra pixel values}
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra);
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra);
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra);
{$ENDIF}
{Move to next column}
inc(Src, 6);
inc(Dest, ColumnIncrement[Pass] * 3 - 3);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Copy <20>mages with palette using bit depths 1, 4 or 8}
procedure TChunkIDAT.CopyInterlacedPalette148(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
const
BitTable: Array[1..8] of Integer = ($1, $3, 0, $F, 0, 0, 0, $FF);
StartBit: Array[1..8] of Integer = (7 , 0 , 0, 4, 0, 0, 0, 0);
var
CurBit, Col: Integer;
Dest2: PChar;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
repeat
{Copy data}
CurBit := StartBit[Header.BitDepth];
repeat
{Adjust pointer to pixel byte bounds}
Dest2 := pChar(Longint(Dest) + (Header.BitDepth * Col) div 8);
{Copy data}
Byte(Dest2^) := Byte(Dest2^) or
( ((Byte(Src^) shr CurBit) and BitTable[Header.BitDepth])
shl (StartBit[Header.BitDepth] - (Col * Header.BitDepth mod 8)));
{Move to next column}
inc(Col, ColumnIncrement[Pass]);
{Will read next bits}
dec(CurBit, Header.BitDepth);
until CurBit < 0;
{Move to next byte in source}
inc(Src);
until Col >= ImageWidth;
end;
{Copy <20>mages with palette using bit depth 2}
procedure TChunkIDAT.CopyInterlacedPalette2(const Pass: Byte; Src, Dest,
Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
CurBit, Col: Integer;
Dest2: PChar;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
repeat
{Copy data}
CurBit := 6;
repeat
{Adjust pointer to pixel byte bounds}
Dest2 := pChar(Longint(Dest) + Col div 2);
{Copy data}
Byte(Dest2^) := Byte(Dest2^) or (((Byte(Src^) shr CurBit) and $3)
shl (4 - (4 * Col) mod 8));
{Move to next column}
inc(Col, ColumnIncrement[Pass]);
{Will read next bits}
dec(CurBit, 2);
until CurBit < 0;
{Move to next byte in source}
inc(Src);
until Col >= ImageWidth;
end;
{Copy <20>mages with grayscale using bit depth 2}
procedure TChunkIDAT.CopyInterlacedGray2(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
CurBit, Col: Integer;
Dest2: PChar;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
repeat
{Copy data}
CurBit := 6;
repeat
{Adjust pointer to pixel byte bounds}
Dest2 := pChar(Longint(Dest) + Col div 2);
{Copy data}
Byte(Dest2^) := Byte(Dest2^) or ((((Byte(Src^) shr CurBit) shl 2) and $F)
shl (4 - (Col*4) mod 8));
{Move to next column}
inc(Col, ColumnIncrement[Pass]);
{Will read next bits}
dec(CurBit, 2);
until CurBit < 0;
{Move to next byte in source}
inc(Src);
until Col >= ImageWidth;
end;
{Copy <20>mages with palette using 2 bytes for each pixel}
procedure TChunkIDAT.CopyInterlacedGrayscale16(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Dest := pChar(Longint(Dest) + Col);
repeat
{Copy this row}
Dest^ := Src^; inc(Dest);
{$IFDEF Store16bits}
Extra^ := pChar(Longint(Src) + 1)^; inc(Extra);
{$ENDIF}
{Move to next column}
inc(Src, 2);
inc(Dest, ColumnIncrement[Pass] - 1);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Decodes interlaced RGB alpha with 1 byte for each sample}
procedure TChunkIDAT.CopyInterlacedRGBAlpha8(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Dest := pChar(Longint(Dest) + Col * 3);
Trans := pChar(Longint(Trans) + Col);
repeat
{Copy this row and alpha value}
Trans^ := pChar(Longint(Src) + 3)^;
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
{Move to next column}
inc(Src, 4);
inc(Dest, ColumnIncrement[Pass] * 3 - 3);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Decodes interlaced RGB alpha with 2 bytes for each sample}
procedure TChunkIDAT.CopyInterlacedRGBAlpha16(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Dest := pChar(Longint(Dest) + Col * 3);
Trans := pChar(Longint(Trans) + Col);
repeat
{Copy this row and alpha value}
Trans^ := pChar(Longint(Src) + 6)^;
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
{$IFDEF Store16bits}
{Copy extra pixel values}
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra);
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra);
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra);
{$ENDIF}
{Move to next column}
inc(Src, 8);
inc(Dest, ColumnIncrement[Pass] * 3 - 3);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Decodes 8 bit grayscale image followed by an alpha sample}
procedure TChunkIDAT.CopyInterlacedGrayscaleAlpha8(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
Col: Integer;
begin
{Get first column, pointers to the data and enter in loop}
Col := ColumnStart[Pass];
Dest := pChar(Longint(Dest) + Col);
Trans := pChar(Longint(Trans) + Col);
repeat
{Copy this grayscale value and alpha}
Dest^ := Src^; inc(Src);
Trans^ := Src^; inc(Src);
{Move to next column}
inc(Dest, ColumnIncrement[Pass]);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Decodes 16 bit grayscale image followed by an alpha sample}
procedure TChunkIDAT.CopyInterlacedGrayscaleAlpha16(const Pass: Byte;
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
Col: Integer;
begin
{Get first column, pointers to the data and enter in loop}
Col := ColumnStart[Pass];
Dest := pChar(Longint(Dest) + Col);
Trans := pChar(Longint(Trans) + Col);
repeat
{$IFDEF Store16bits}
Extra^ := pChar(Longint(Src) + 1)^; inc(Extra);
{$ENDIF}
{Copy this grayscale value and alpha, transforming 16 bits into 8}
Dest^ := Src^; inc(Src, 2);
Trans^ := Src^; inc(Src, 2);
{Move to next column}
inc(Dest, ColumnIncrement[Pass]);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Decodes an interlaced image}
procedure TChunkIDAT.DecodeInterlacedAdam7(Stream: TStream;
var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal);
var
CurrentPass: Byte;
PixelsThisRow: Integer;
CurrentRow: Integer;
Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pChar;
CopyProc: procedure(const Pass: Byte; Src, Dest,
Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar) of object;
begin
CopyProc := nil; {Initialize}
{Determine method to copy the image data}
case Header.ColorType of
{R, G, B values for each pixel}
COLOR_RGB:
case Header.BitDepth of
8: CopyProc := CopyInterlacedRGB8;
16: CopyProc := CopyInterlacedRGB16;
end {case Header.BitDepth};
{Palette}
COLOR_PALETTE, COLOR_GRAYSCALE:
case Header.BitDepth of
1, 4, 8: CopyProc := CopyInterlacedPalette148;
2 : if Header.ColorType = COLOR_PALETTE then
CopyProc := CopyInterlacedPalette2
else
CopyProc := CopyInterlacedGray2;
16 : CopyProc := CopyInterlacedGrayscale16;
end;
{RGB followed by alpha}
COLOR_RGBALPHA:
case Header.BitDepth of
8: CopyProc := CopyInterlacedRGBAlpha8;
16: CopyProc := CopyInterlacedRGBAlpha16;
end;
{Grayscale followed by alpha}
COLOR_GRAYSCALEALPHA:
case Header.BitDepth of
8: CopyProc := CopyInterlacedGrayscaleAlpha8;
16: CopyProc := CopyInterlacedGrayscaleAlpha16;
end;
end {case Header.ColorType};
{Adam7 method has 7 passes to make the final image}
FOR CurrentPass := 0 TO 6 DO
begin
{Calculates the number of pixels and bytes for this pass row}
PixelsThisRow := (ImageWidth - ColumnStart[CurrentPass] +
ColumnIncrement[CurrentPass] - 1) div ColumnIncrement[CurrentPass];
Row_Bytes := BytesForPixels(PixelsThisRow, Header.ColorType,
Header.BitDepth);
{Clear buffer for this pass}
ZeroMemory(Row_Buffer[not RowUsed], Row_Bytes);
{Get current row index}
CurrentRow := RowStart[CurrentPass];
{Get a pointer to the current row image data}
Data := Ptr(Longint(Header.ImageData) + Header.BytesPerRow *
(ImageHeight - 1 - CurrentRow));
Trans := Ptr(Longint(Header.ImageAlpha) + ImageWidth * CurrentRow);
{$IFDEF Store16bits}
Extra := Ptr(Longint(Header.ExtraImageData) + Header.BytesPerRow *
(ImageHeight - 1 - CurrentRow));
{$ENDIF}
if Row_Bytes > 0 then {There must have bytes for this interlaced pass}
while CurrentRow < ImageHeight do
begin
{Reads this line and filter}
if IDATZlibRead(ZLIBStream, @Row_Buffer[RowUsed][0], Row_Bytes + 1,
EndPos, CRCFile) = 0 then break;
FilterRow;
{Copy image data}
CopyProc(CurrentPass, @Row_Buffer[RowUsed][1], Data, Trans
{$IFDEF Store16bits}, Extra{$ENDIF});
{Use the other RowBuffer item}
RowUsed := not RowUsed;
{Move to the next row}
inc(CurrentRow, RowIncrement[CurrentPass]);
{Move pointer to the next line}
dec(Data, RowIncrement[CurrentPass] * Header.BytesPerRow);
inc(Trans, RowIncrement[CurrentPass] * ImageWidth);
{$IFDEF Store16bits}
dec(Extra, RowIncrement[CurrentPass] * Header.BytesPerRow);
{$ENDIF}
end {while CurrentRow < ImageHeight};
end {FOR CurrentPass};
end;
{Copy 8 bits RGB image}
procedure TChunkIDAT.CopyNonInterlacedRGB8(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
{Copy pixel values}
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
{Move to next pixel}
inc(Src, 3);
end {for I}
end;
{Copy 16 bits RGB image}
procedure TChunkIDAT.CopyNonInterlacedRGB16(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
//Since windows does not supports 2 bytes for
//each R, G, B value, the method will read only 1 byte from it
{Copy pixel values}
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
{$IFDEF Store16bits}
{Copy extra pixel values}
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra);
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra);
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra);
{$ENDIF}
{Move to next pixel}
inc(Src, 6);
end {for I}
end;
{Copy types using palettes (1, 4 or 8 bits per pixel)}
procedure TChunkIDAT.CopyNonInterlacedPalette148(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
begin
{It's simple as copying the data}
CopyMemory(Dest, Src, Row_Bytes);
end;
{Copy grayscale types using 2 bits for each pixel}
procedure TChunkIDAT.CopyNonInterlacedGray2(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
i: Integer;
begin
{2 bits is not supported, this routine will converted into 4 bits}
FOR i := 1 TO Row_Bytes do
begin
Byte(Dest^) := ((Byte(Src^) shr 2) and $F) or ((Byte(Src^)) and $F0);
inc(Dest);
Byte(Dest^) := ((Byte(Src^) shl 2) and $F) or ((Byte(Src^) shl 4) and $F0);
inc(Dest);
inc(Src);
end {FOR i}
end;
{Copy types using palette with 2 bits for each pixel}
procedure TChunkIDAT.CopyNonInterlacedPalette2(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
i: Integer;
begin
{2 bits is not supported, this routine will converted into 4 bits}
FOR i := 1 TO Row_Bytes do
begin
Byte(Dest^) := ((Byte(Src^) shr 4) and $3) or ((Byte(Src^) shr 2) and $30);
inc(Dest);
Byte(Dest^) := (Byte(Src^) and $3) or ((Byte(Src^) shl 2) and $30);
inc(Dest);
inc(Src);
end {FOR i}
end;
{Copy grayscale images with 16 bits}
procedure TChunkIDAT.CopyNonInterlacedGrayscale16(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
{Windows does not supports 16 bits for each pixel in grayscale}
{mode, so reduce to 8}
Dest^ := Src^; inc(Dest);
{$IFDEF Store16bits}
Extra^ := pChar(Longint(Src) + 1)^; inc(Extra);
{$ENDIF}
{Move to next pixel}
inc(Src, 2);
end {for I}
end;
{Copy 8 bits per sample RGB images followed by an alpha byte}
procedure TChunkIDAT.CopyNonInterlacedRGBAlpha8(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
i: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
{Copy pixel values and transparency}
Trans^ := pChar(Longint(Src) + 3)^;
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
{Move to next pixel}
inc(Src, 4); inc(Trans);
end {for I}
end;
{Copy 16 bits RGB image with alpha using 2 bytes for each sample}
procedure TChunkIDAT.CopyNonInterlacedRGBAlpha16(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
//Copy rgb and alpha values (transforming from 16 bits to 8 bits)
{Copy pixel values}
Trans^ := pChar(Longint(Src) + 6)^;
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest);
{$IFDEF Store16bits}
{Copy extra pixel values}
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra);
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra);
Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra);
{$ENDIF}
{Move to next pixel}
inc(Src, 8); inc(Trans);
end {for I}
end;
{Copy 8 bits per sample grayscale followed by alpha}
procedure TChunkIDAT.CopyNonInterlacedGrayscaleAlpha8(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
{Copy alpha value and then gray value}
Dest^ := Src^; inc(Src);
Trans^ := Src^; inc(Src);
inc(Dest); inc(Trans);
end;
end;
{Copy 16 bits per sample grayscale followed by alpha}
procedure TChunkIDAT.CopyNonInterlacedGrayscaleAlpha16(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
{Copy alpha value and then gray value}
{$IFDEF Store16bits}
Extra^ := pChar(Longint(Src) + 1)^; inc(Extra);
{$ENDIF}
Dest^ := Src^; inc(Src, 2);
Trans^ := Src^; inc(Src, 2);
inc(Dest); inc(Trans);
end;
end;
{Decode non interlaced image}
procedure TChunkIDAT.DecodeNonInterlaced(Stream: TStream;
var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal);
var
j: Cardinal;
Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pChar;
CopyProc: procedure(
Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar) of object;
begin
CopyProc := nil; {Initialize}
{Determines the method to copy the image data}
case Header.ColorType of
{R, G, B values}
COLOR_RGB:
case Header.BitDepth of
8: CopyProc := CopyNonInterlacedRGB8;
16: CopyProc := CopyNonInterlacedRGB16;
end;
{Types using palettes}
COLOR_PALETTE, COLOR_GRAYSCALE:
case Header.BitDepth of
1, 4, 8: CopyProc := CopyNonInterlacedPalette148;
2 : if Header.ColorType = COLOR_PALETTE then
CopyProc := CopyNonInterlacedPalette2
else
CopyProc := CopyNonInterlacedGray2;
16 : CopyProc := CopyNonInterlacedGrayscale16;
end;
{R, G, B followed by alpha}
COLOR_RGBALPHA:
case Header.BitDepth of
8 : CopyProc := CopyNonInterlacedRGBAlpha8;
16 : CopyProc := CopyNonInterlacedRGBAlpha16;
end;
{Grayscale followed by alpha}
COLOR_GRAYSCALEALPHA:
case Header.BitDepth of
8 : CopyProc := CopyNonInterlacedGrayscaleAlpha8;
16 : CopyProc := CopyNonInterlacedGrayscaleAlpha16;
end;
end;
{Get the image data pointer}
Longint(Data) := Longint(Header.ImageData) +
Header.BytesPerRow * (ImageHeight - 1);
Trans := Header.ImageAlpha;
{$IFDEF Store16bits}
Longint(Extra) := Longint(Header.ExtraImageData) +
Header.BytesPerRow * (ImageHeight - 1);
{$ENDIF}
{Reads each line}
FOR j := 0 to ImageHeight - 1 do
begin
{Read this line Row_Buffer[RowUsed][0] if the filter type for this line}
if IDATZlibRead(ZLIBStream, @Row_Buffer[RowUsed][0], Row_Bytes + 1, EndPos,
CRCFile) = 0 then break;
{Filter the current row}
FilterRow;
{Copies non interlaced row to image}
CopyProc(@Row_Buffer[RowUsed][1], Data, Trans{$IFDEF Store16bits}, Extra
{$ENDIF});
{Invert line used}
RowUsed := not RowUsed;
dec(Data, Header.BytesPerRow);
{$IFDEF Store16bits}dec(Extra, Header.BytesPerRow);{$ENDIF}
inc(Trans, ImageWidth);
end {for I};
end;
{Filter the current line}
procedure TChunkIDAT.FilterRow;
var
pp: Byte;
vv, left, above, aboveleft: Integer;
Col: Cardinal;
begin
{Test the filter}
case Row_Buffer[RowUsed]^[0] of
{No filtering for this line}
FILTER_NONE: begin end;
{AND 255 serves only to never let the result be larger than one byte}
{Sub filter}
FILTER_SUB:
FOR Col := Offset + 1 to Row_Bytes DO
Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] +
Row_Buffer[RowUsed][Col - Offset]) and 255;
{Up filter}
FILTER_UP:
FOR Col := 1 to Row_Bytes DO
Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] +
Row_Buffer[not RowUsed][Col]) and 255;
{Average filter}
FILTER_AVERAGE:
FOR Col := 1 to Row_Bytes DO
begin
{Obtains up and left pixels}
above := Row_Buffer[not RowUsed][Col];
if col - 1 < Offset then
left := 0
else
Left := Row_Buffer[RowUsed][Col - Offset];
{Calculates}
Row_Buffer[RowUsed][Col] := (Row_Buffer[RowUsed][Col] +
(left + above) div 2) and 255;
end;
{Paeth filter}
FILTER_PAETH:
begin
{Initialize}
left := 0;
aboveleft := 0;
{Test each byte}
FOR Col := 1 to Row_Bytes DO
begin
{Obtains above pixel}
above := Row_Buffer[not RowUsed][Col];
{Obtains left and top-left pixels}
if (col - 1 >= offset) Then
begin
left := row_buffer[RowUsed][col - offset];
aboveleft := row_buffer[not RowUsed][col - offset];
end;
{Obtains current pixel and paeth predictor}
vv := row_buffer[RowUsed][Col];
pp := PaethPredictor(left, above, aboveleft);
{Calculates}
Row_Buffer[RowUsed][Col] := (pp + vv) and $FF;
end {for};
end;
end {case};
end;
{Reads the image data from the stream}
function TChunkIDAT.LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
Size: Integer): Boolean;
var
ZLIBStream: TZStreamRec2;
CRCCheck,
CRCFile : Cardinal;
begin
{Get pointer to the header chunk}
Header := Owner.Chunks.Item[0] as TChunkIHDR;
{Build palette if necessary}
if Header.HasPalette then PreparePalette();
{Copy image width and height}
ImageWidth := Header.Width;
ImageHeight := Header.Height;
{Initialize to calculate CRC}
{$IFDEF CheckCRC}
CRCFile := update_crc($ffffffff, @ChunkName[0], 4);
{$ENDIF}
Owner.GetPixelInfo(Row_Bytes, Offset); {Obtain line information}
ZLIBStream := ZLIBInitInflate(Stream); {Initializes decompression}
{Calculate ending position for the current IDAT chunk}
EndPos := Stream.Position + Size;
{Allocate memory}
GetMem(Row_Buffer[false], Row_Bytes + 1);
GetMem(Row_Buffer[true], Row_Bytes + 1);
ZeroMemory(Row_Buffer[false], Row_bytes + 1);
{Set the variable to alternate the Row_Buffer item to use}
RowUsed := TRUE;
{Call special methods for the different interlace methods}
case Owner.InterlaceMethod of
imNone: DecodeNonInterlaced(stream, ZLIBStream, Size, crcfile);
imAdam7: DecodeInterlacedAdam7(stream, ZLIBStream, size, crcfile);
end;
{Free memory}
ZLIBTerminateInflate(ZLIBStream); {Terminates decompression}
FreeMem(Row_Buffer[False], Row_Bytes + 1);
FreeMem(Row_Buffer[True], Row_Bytes + 1);
{Now checks CRC}
Stream.Read(CRCCheck, 4);
{$IFDEF CheckCRC}
CRCFile := CRCFile xor $ffffffff;
CRCCheck := ByteSwap(CRCCheck);
Result := CRCCheck = CRCFile;
{Handle CRC error}
if not Result then
begin
{In case it coult not load chunk}
Owner.RaiseError(EPngInvalidCRC, EPngInvalidCRCText);
exit;
end;
{$ELSE}Result := TRUE; {$ENDIF}
end;
const
IDATHeader: Array[0..3] of char = ('I', 'D', 'A', 'T');
BUFFER = 5;
{Saves the IDAT chunk to a stream}
function TChunkIDAT.SaveToStream(Stream: TStream): Boolean;
var
ZLIBStream : TZStreamRec2;
begin
{Get pointer to the header chunk}
Header := Owner.Chunks.Item[0] as TChunkIHDR;
{Copy image width and height}
ImageWidth := Header.Width;
ImageHeight := Header.Height;
Owner.GetPixelInfo(Row_Bytes, Offset); {Obtain line information}
{Allocate memory}
GetMem(Encode_Buffer[BUFFER], Row_Bytes);
ZeroMemory(Encode_Buffer[BUFFER], Row_Bytes);
{Allocate buffers for the filters selected}
{Filter none will always be calculated to the other filters to work}
GetMem(Encode_Buffer[FILTER_NONE], Row_Bytes);
ZeroMemory(Encode_Buffer[FILTER_NONE], Row_Bytes);
if pfSub in Owner.Filters then
GetMem(Encode_Buffer[FILTER_SUB], Row_Bytes);
if pfUp in Owner.Filters then
GetMem(Encode_Buffer[FILTER_UP], Row_Bytes);
if pfAverage in Owner.Filters then
GetMem(Encode_Buffer[FILTER_AVERAGE], Row_Bytes);
if pfPaeth in Owner.Filters then
GetMem(Encode_Buffer[FILTER_PAETH], Row_Bytes);
{Initialize ZLIB}
ZLIBStream := ZLIBInitDeflate(Stream, Owner.fCompressionLevel,
Owner.MaxIdatSize);
{Write data depending on the interlace method}
case Owner.InterlaceMethod of
imNone: EncodeNonInterlaced(stream, ZLIBStream);
imAdam7: EncodeInterlacedAdam7(stream, ZLIBStream);
end;
{Terminates ZLIB}
ZLIBTerminateDeflate(ZLIBStream);
{Release allocated memory}
FreeMem(Encode_Buffer[BUFFER], Row_Bytes);
FreeMem(Encode_Buffer[FILTER_NONE], Row_Bytes);
if pfSub in Owner.Filters then
FreeMem(Encode_Buffer[FILTER_SUB], Row_Bytes);
if pfUp in Owner.Filters then
FreeMem(Encode_Buffer[FILTER_UP], Row_Bytes);
if pfAverage in Owner.Filters then
FreeMem(Encode_Buffer[FILTER_AVERAGE], Row_Bytes);
if pfPaeth in Owner.Filters then
FreeMem(Encode_Buffer[FILTER_PAETH], Row_Bytes);
{Everything went ok}
Result := True;
end;
{Writes the IDAT using the settings}
procedure WriteIDAT(Stream: TStream; Data: Pointer; const Length: Cardinal);
var
ChunkLen, CRC: Cardinal;
begin
{Writes IDAT header}
ChunkLen := ByteSwap(Length);
Stream.Write(ChunkLen, 4); {Chunk length}
Stream.Write(IDATHeader[0], 4); {Idat header}
CRC := update_crc($ffffffff, @IDATHeader[0], 4); {Crc part for header}
{Writes IDAT data and calculates CRC for data}
Stream.Write(Data^, Length);
CRC := Byteswap(update_crc(CRC, Data, Length) xor $ffffffff);
{Writes final CRC}
Stream.Write(CRC, 4);
end;
{Compress and writes IDAT chunk data}
procedure TChunkIDAT.IDATZlibWrite(var ZLIBStream: TZStreamRec2;
Buffer: Pointer; const Length: Cardinal);
begin
with ZLIBStream, ZLIBStream.ZLIB do
begin
{Set data to be compressed}
next_in := Buffer;
avail_in := Length;
{Compress all the data avaliable to compress}
while avail_in > 0 do
begin
deflate(ZLIB, Z_NO_FLUSH);
{The whole buffer was used, save data to stream and restore buffer}
if avail_out = 0 then
begin
{Writes this IDAT chunk}
WriteIDAT(fStream, Data, Owner.MaxIdatSize);
{Restore buffer}
next_out := Data;
avail_out := Owner.MaxIdatSize;
end {if avail_out = 0};
end {while avail_in};
end {with ZLIBStream, ZLIBStream.ZLIB}
end;
{Finishes compressing data to write IDAT chunk}
procedure TChunkIDAT.FinishIDATZlib(var ZLIBStream: TZStreamRec2);
begin
with ZLIBStream, ZLIBStream.ZLIB do
begin
{Set data to be compressed}
next_in := nil;
avail_in := 0;
while deflate(ZLIB,Z_FINISH) <> Z_STREAM_END do
begin
{Writes this IDAT chunk}
WriteIDAT(fStream, Data, Owner.MaxIdatSize - avail_out);
{Re-update buffer}
next_out := Data;
avail_out := Owner.MaxIdatSize;
end;
if avail_out < Owner.MaxIdatSize then
{Writes final IDAT}
WriteIDAT(fStream, Data, Owner.MaxIdatSize - avail_out);
end {with ZLIBStream, ZLIBStream.ZLIB};
end;
{Copy memory to encode RGB image with 1 byte for each color sample}
procedure TChunkIDAT.EncodeNonInterlacedRGB8(Src, Dest, Trans: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
{Copy pixel values}
Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest);
{Move to next pixel}
inc(Src, 3);
end {for I}
end;
{Copy memory to encode RGB images with 16 bits for each color sample}
procedure TChunkIDAT.EncodeNonInterlacedRGB16(Src, Dest, Trans: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
//Now we copy from 1 byte for each sample stored to a 2 bytes (or 1 word)
//for sample
{Copy pixel values}
pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest, 2);
pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest, 2);
pWORD(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest, 2);
{Move to next pixel}
inc(Src, 3);
end {for I}
end;
{Copy memory to encode types using palettes (1, 4 or 8 bits per pixel)}
procedure TChunkIDAT.EncodeNonInterlacedPalette148(Src, Dest, Trans: pChar);
begin
{It's simple as copying the data}
CopyMemory(Dest, Src, Row_Bytes);
end;
{Copy memory to encode grayscale images with 2 bytes for each sample}
procedure TChunkIDAT.EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pChar);
var
I: Integer;
begin
FOR I := 1 TO ImageWidth DO
begin
//Now we copy from 1 byte for each sample stored to a 2 bytes (or 1 word)
//for sample
pWORD(Dest)^ := pByte(Longint(Src))^; inc(Dest, 2);
{Move to next pixel}
inc(Src);
end {for I}
end;
{Encode images using RGB followed by an alpha value using 1 byte for each}
procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pChar);
var
i: Integer;
begin
{Copy the data to the destination, including data from Trans pointer}
FOR i := 1 TO ImageWidth do
begin
Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) )^]; inc(Dest);
Dest^ := Trans^; inc(Dest);
inc(Src, 3); inc(Trans);
end {for i};
end;
{Encode images using RGB followed by an alpha value using 2 byte for each}
procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pChar);
var
i: Integer;
begin
{Copy the data to the destination, including data from Trans pointer}
FOR i := 1 TO ImageWidth do
begin
pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) + 2)^]; inc(Dest, 2);
pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) + 1)^]; inc(Dest, 2);
pWord(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) )^]; inc(Dest, 2);
pWord(Dest)^ := PByte(Longint(Trans) )^; inc(Dest, 2);
inc(Src, 3); inc(Trans);
end {for i};
end;
{Encode grayscale images followed by an alpha value using 1 byte for each}
procedure TChunkIDAT.EncodeNonInterlacedGrayscaleAlpha8(
Src, Dest, Trans: pChar);
var
i: Integer;
begin
{Copy the data to the destination, including data from Trans pointer}
FOR i := 1 TO ImageWidth do
begin
Dest^ := Src^; inc(Dest);
Dest^ := Trans^; inc(Dest);
inc(Src); inc(Trans);
end {for i};
end;
{Encode grayscale images followed by an alpha value using 2 byte for each}
procedure TChunkIDAT.EncodeNonInterlacedGrayscaleAlpha16(
Src, Dest, Trans: pChar);
var
i: Integer;
begin
{Copy the data to the destination, including data from Trans pointer}
FOR i := 1 TO ImageWidth do
begin
pWord(Dest)^ := pByte(Src)^; inc(Dest, 2);
pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2);
inc(Src); inc(Trans);
end {for i};
end;
{Encode non interlaced images}
procedure TChunkIDAT.EncodeNonInterlaced(Stream: TStream;
var ZLIBStream: TZStreamRec2);
var
{Current line}
j: Cardinal;
{Pointers to image data}
Data, Trans: PChar;
{Filter used for this line}
Filter: Byte;
{Method which will copy the data into the buffer}
CopyProc: procedure(Src, Dest, Trans: pChar) of object;
begin
CopyProc := nil; {Initialize to avoid warnings}
{Defines the method to copy the data to the buffer depending on}
{the image parameters}
case Header.ColorType of
{R, G, B values}
COLOR_RGB:
case Header.BitDepth of
8: CopyProc := EncodeNonInterlacedRGB8;
16: CopyProc := EncodeNonInterlacedRGB16;
end;
{Palette and grayscale values}
COLOR_GRAYSCALE, COLOR_PALETTE:
case Header.BitDepth of
1, 4, 8: CopyProc := EncodeNonInterlacedPalette148;
16: CopyProc := EncodeNonInterlacedGrayscale16;
end;
{RGB with a following alpha value}
COLOR_RGBALPHA:
case Header.BitDepth of
8: CopyProc := EncodeNonInterlacedRGBAlpha8;
16: CopyProc := EncodeNonInterlacedRGBAlpha16;
end;
{Grayscale images followed by an alpha}
COLOR_GRAYSCALEALPHA:
case Header.BitDepth of
8: CopyProc := EncodeNonInterlacedGrayscaleAlpha8;
16: CopyProc := EncodeNonInterlacedGrayscaleAlpha16;
end;
end {case Header.ColorType};
{Get the image data pointer}
Longint(Data) := Longint(Header.ImageData) +
Header.BytesPerRow * (ImageHeight - 1);
Trans := Header.ImageAlpha;
{Writes each line}
FOR j := 0 to ImageHeight - 1 do
begin
{Copy data into buffer}
CopyProc(Data, @Encode_Buffer[BUFFER][0], Trans);
{Filter data}
Filter := FilterToEncode;
{Compress data}
IDATZlibWrite(ZLIBStream, @Filter, 1);
IDATZlibWrite(ZLIBStream, @Encode_Buffer[Filter][0], Row_Bytes);
{Adjust pointers to the actual image data}
dec(Data, Header.BytesPerRow);
inc(Trans, ImageWidth);
end;
{Compress and finishes copying the remaining data}
FinishIDATZlib(ZLIBStream);
end;
{Copy memory to encode interlaced images using RGB value with 1 byte for}
{each color sample}
procedure TChunkIDAT.EncodeInterlacedRGB8(const Pass: Byte;
Src, Dest, Trans: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Src := pChar(Longint(Src) + Col * 3);
repeat
{Copy this row}
Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest);
{Move to next column}
inc(Src, ColumnIncrement[Pass] * 3);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Copy memory to encode interlaced RGB images with 2 bytes each color sample}
procedure TChunkIDAT.EncodeInterlacedRGB16(const Pass: Byte;
Src, Dest, Trans: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Src := pChar(Longint(Src) + Col * 3);
repeat
{Copy this row}
pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest, 2);
pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest, 2);
pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest, 2);
{Move to next column}
inc(Src, ColumnIncrement[Pass] * 3);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Copy memory to encode interlaced images using palettes using bit depths}
{1, 4, 8 (each pixel in the image)}
procedure TChunkIDAT.EncodeInterlacedPalette148(const Pass: Byte;
Src, Dest, Trans: pChar);
const
BitTable: Array[1..8] of Integer = ($1, $3, 0, $F, 0, 0, 0, $FF);
StartBit: Array[1..8] of Integer = (7 , 0 , 0, 4, 0, 0, 0, 0);
var
CurBit, Col: Integer;
Src2: PChar;
begin
{Clean the line}
fillchar(Dest^, Row_Bytes, #0);
{Get first column and enter in loop}
Col := ColumnStart[Pass];
with Header.BitmapInfo.bmiHeader do
repeat
{Copy data}
CurBit := StartBit[biBitCount];
repeat
{Adjust pointer to pixel byte bounds}
Src2 := pChar(Longint(Src) + (biBitCount * Col) div 8);
{Copy data}
Byte(Dest^) := Byte(Dest^) or
(((Byte(Src2^) shr (StartBit[Header.BitDepth] - (biBitCount * Col)
mod 8))) and (BitTable[biBitCount])) shl CurBit;
{Move to next column}
inc(Col, ColumnIncrement[Pass]);
{Will read next bits}
dec(CurBit, biBitCount);
until CurBit < 0;
{Move to next byte in source}
inc(Dest);
until Col >= ImageWidth;
end;
{Copy to encode interlaced grayscale images using 16 bits for each sample}
procedure TChunkIDAT.EncodeInterlacedGrayscale16(const Pass: Byte;
Src, Dest, Trans: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Src := pChar(Longint(Src) + Col);
repeat
{Copy this row}
pWord(Dest)^ := Byte(Src^); inc(Dest, 2);
{Move to next column}
inc(Src, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Copy to encode interlaced rgb images followed by an alpha value, all using}
{one byte for each sample}
procedure TChunkIDAT.EncodeInterlacedRGBAlpha8(const Pass: Byte;
Src, Dest, Trans: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Src := pChar(Longint(Src) + Col * 3);
Trans := pChar(Longint(Trans) + Col);
repeat
{Copy this row}
Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest);
Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest);
Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest);
Dest^ := Trans^; inc(Dest);
{Move to next column}
inc(Src, ColumnIncrement[Pass] * 3);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Copy to encode interlaced rgb images followed by an alpha value, all using}
{two byte for each sample}
procedure TChunkIDAT.EncodeInterlacedRGBAlpha16(const Pass: Byte;
Src, Dest, Trans: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Src := pChar(Longint(Src) + Col * 3);
Trans := pChar(Longint(Trans) + Col);
repeat
{Copy this row}
pWord(Dest)^ := pByte(Longint(Src) + 2)^; inc(Dest, 2);
pWord(Dest)^ := pByte(Longint(Src) + 1)^; inc(Dest, 2);
pWord(Dest)^ := pByte(Longint(Src) )^; inc(Dest, 2);
pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2);
{Move to next column}
inc(Src, ColumnIncrement[Pass] * 3);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Copy to encode grayscale interlaced images followed by an alpha value, all}
{using 1 byte for each sample}
procedure TChunkIDAT.EncodeInterlacedGrayscaleAlpha8(const Pass: Byte;
Src, Dest, Trans: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Src := pChar(Longint(Src) + Col);
Trans := pChar(Longint(Trans) + Col);
repeat
{Copy this row}
Dest^ := Src^; inc(Dest);
Dest^ := Trans^; inc(Dest);
{Move to next column}
inc(Src, ColumnIncrement[Pass]);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Copy to encode grayscale interlaced images followed by an alpha value, all}
{using 2 bytes for each sample}
procedure TChunkIDAT.EncodeInterlacedGrayscaleAlpha16(const Pass: Byte;
Src, Dest, Trans: pChar);
var
Col: Integer;
begin
{Get first column and enter in loop}
Col := ColumnStart[Pass];
Src := pChar(Longint(Src) + Col);
Trans := pChar(Longint(Trans) + Col);
repeat
{Copy this row}
pWord(Dest)^ := pByte(Src)^; inc(Dest, 2);
pWord(Dest)^ := pByte(Trans)^; inc(Dest, 2);
{Move to next column}
inc(Src, ColumnIncrement[Pass]);
inc(Trans, ColumnIncrement[Pass]);
inc(Col, ColumnIncrement[Pass]);
until Col >= ImageWidth;
end;
{Encode interlaced images}
procedure TChunkIDAT.EncodeInterlacedAdam7(Stream: TStream;
var ZLIBStream: TZStreamRec2);
var
CurrentPass, Filter: Byte;
PixelsThisRow: Integer;
CurrentRow : Integer;
Trans, Data: pChar;
CopyProc: procedure(const Pass: Byte;
Src, Dest, Trans: pChar) of object;
begin
CopyProc := nil; {Initialize to avoid warnings}
{Defines the method to copy the data to the buffer depending on}
{the image parameters}
case Header.ColorType of
{R, G, B values}
COLOR_RGB:
case Header.BitDepth of
8: CopyProc := EncodeInterlacedRGB8;
16: CopyProc := EncodeInterlacedRGB16;
end;
{Grayscale and palette}
COLOR_PALETTE, COLOR_GRAYSCALE:
case Header.BitDepth of
1, 4, 8: CopyProc := EncodeInterlacedPalette148;
16: CopyProc := EncodeInterlacedGrayscale16;
end;
{RGB followed by alpha}
COLOR_RGBALPHA:
case Header.BitDepth of
8: CopyProc := EncodeInterlacedRGBAlpha8;
16: CopyProc := EncodeInterlacedRGBAlpha16;
end;
COLOR_GRAYSCALEALPHA:
{Grayscale followed by alpha}
case Header.BitDepth of
8: CopyProc := EncodeInterlacedGrayscaleAlpha8;
16: CopyProc := EncodeInterlacedGrayscaleAlpha16;
end;
end {case Header.ColorType};
{Compress the image using the seven passes for ADAM 7}
FOR CurrentPass := 0 TO 6 DO
begin
{Calculates the number of pixels and bytes for this pass row}
PixelsThisRow := (ImageWidth - ColumnStart[CurrentPass] +
ColumnIncrement[CurrentPass] - 1) div ColumnIncrement[CurrentPass];
Row_Bytes := BytesForPixels(PixelsThisRow, Header.ColorType,
Header.BitDepth);
ZeroMemory(Encode_Buffer[FILTER_NONE], Row_Bytes);
{Get current row index}
CurrentRow := RowStart[CurrentPass];
{Get a pointer to the current row image data}
Data := Ptr(Longint(Header.ImageData) + Header.BytesPerRow *
(ImageHeight - 1 - CurrentRow));
Trans := Ptr(Longint(Header.ImageAlpha) + ImageWidth * CurrentRow);
{Process all the image rows}
if Row_Bytes > 0 then
while CurrentRow < ImageHeight do
begin
{Copy data into buffer}
CopyProc(CurrentPass, Data, @Encode_Buffer[BUFFER][0], Trans);
{Filter data}
Filter := FilterToEncode;
{Compress data}
IDATZlibWrite(ZLIBStream, @Filter, 1);
IDATZlibWrite(ZLIBStream, @Encode_Buffer[Filter][0], Row_Bytes);
{Move to the next row}
inc(CurrentRow, RowIncrement[CurrentPass]);
{Move pointer to the next line}
dec(Data, RowIncrement[CurrentPass] * Header.BytesPerRow);
inc(Trans, RowIncrement[CurrentPass] * ImageWidth);
end {while CurrentRow < ImageHeight}
end {CurrentPass};
{Compress and finishes copying the remaining data}
FinishIDATZlib(ZLIBStream);
end;
{Filters the row to be encoded and returns the best filter}
function TChunkIDAT.FilterToEncode: Byte;
var
Run, LongestRun, ii, jj: Cardinal;
Last, Above, LastAbove: Byte;
begin
{Selecting more filters using the Filters property from TPngObject}
{increases the chances to the file be much smaller, but decreases}
{the performace}
{This method will creates the same line data using the different}
{filter methods and select the best}
{Sub-filter}
if pfSub in Owner.Filters then
for ii := 0 to Row_Bytes - 1 do
begin
{There is no previous pixel when it's on the first pixel, so}
{set last as zero when in the first}
if (ii >= Offset) then
last := Encode_Buffer[BUFFER]^[ii - Offset]
else
last := 0;
Encode_Buffer[FILTER_SUB]^[ii] := Encode_Buffer[BUFFER]^[ii] - last;
end;
{Up filter}
if pfUp in Owner.Filters then
for ii := 0 to Row_Bytes - 1 do
Encode_Buffer[FILTER_UP]^[ii] := Encode_Buffer[BUFFER]^[ii] -
Encode_Buffer[FILTER_NONE]^[ii];
{Average filter}
if pfAverage in Owner.Filters then
for ii := 0 to Row_Bytes - 1 do
begin
{Get the previous pixel, if the current pixel is the first, the}
{previous is considered to be 0}
if (ii >= Offset) then
last := Encode_Buffer[BUFFER]^[ii - Offset]
else
last := 0;
{Get the pixel above}
above := Encode_Buffer[FILTER_NONE]^[ii];
{Calculates formula to the average pixel}
Encode_Buffer[FILTER_AVERAGE]^[ii] := Encode_Buffer[BUFFER]^[ii] -
(above + last) div 2 ;
end;
{Paeth filter (the slower)}
if pfPaeth in Owner.Filters then
begin
{Initialize}
last := 0;
lastabove := 0;
for ii := 0 to Row_Bytes - 1 do
begin
{In case this pixel is not the first in the line obtains the}
{previous one and the one above the previous}
if (ii >= Offset) then
begin
last := Encode_Buffer[BUFFER]^[ii - Offset];
lastabove := Encode_Buffer[FILTER_NONE]^[ii - Offset];
end;
{Obtains the pixel above}
above := Encode_Buffer[FILTER_NONE]^[ii];
{Calculate paeth filter for this byte}
Encode_Buffer[FILTER_PAETH]^[ii] := Encode_Buffer[BUFFER]^[ii] -
PaethPredictor(last, above, lastabove);
end;
end;
{Now calculates the same line using no filter, which is necessary}
{in order to have data to the filters when the next line comes}
CopyMemory(@Encode_Buffer[FILTER_NONE]^[0],
@Encode_Buffer[BUFFER]^[0], Row_Bytes);
{If only filter none is selected in the filter list, we don't need}
{to proceed and further}
if (Owner.Filters = [pfNone]) or (Owner.Filters = []) then
begin
Result := FILTER_NONE;
exit;
end {if (Owner.Filters = [pfNone...};
{Check which filter is the best by checking which has the larger}
{sequence of the same byte, since they are best compressed}
LongestRun := 0; Result := FILTER_NONE;
for ii := FILTER_NONE TO FILTER_PAETH do
{Check if this filter was selected}
if TFilter(ii) in Owner.Filters then
begin
Run := 0;
{Check if it's the only filter}
if Owner.Filters = [TFilter(ii)] then
begin
Result := ii;
exit;
end;
{Check using a sequence of four bytes}
for jj := 2 to Row_Bytes - 1 do
if (Encode_Buffer[ii]^[jj] = Encode_Buffer [ii]^[jj-1]) or
(Encode_Buffer[ii]^[jj] = Encode_Buffer [ii]^[jj-2]) then
inc(Run); {Count the number of sequences}
{Check if this one is the best so far}
if (Run > LongestRun) then
begin
Result := ii;
LongestRun := Run;
end {if (Run > LongestRun)};
end {if TFilter(ii) in Owner.Filters};
end;
{TChunkPLTE implementation}
{Returns an item in the palette}
function TChunkPLTE.GetPaletteItem(Index: Byte): TRGBQuad;
begin
{Test if item is valid, if not raise error}
if Index > Count - 1 then
Owner.RaiseError(EPNGError, EPNGUnknownPalEntryText)
else
{Returns the item}
Result := Header.BitmapInfo.bmiColors[Index];
end;
{Loads the palette chunk from a stream}
function TChunkPLTE.LoadFromStream(Stream: TStream;
const ChunkName: TChunkName; Size: Integer): Boolean;
type
pPalEntry = ^PalEntry;
PalEntry = record
r, g, b: Byte;
end;
var
j : Integer; {For the FOR}
PalColor : pPalEntry;
palEntries: TMaxLogPalette;
begin
{Let ancestor load data and check CRC}
Result := inherited LoadFromStream(Stream, ChunkName, Size);
if not Result then exit;
{This chunk must be divisible by 3 in order to be valid}
if (Size mod 3 <> 0) or (Size div 3 > 256) then
begin
{Raise error}
Result := FALSE;
Owner.RaiseError(EPNGInvalidPalette, EPNGInvalidPaletteText);
exit;
end {if Size mod 3 <> 0};
{Fill array with the palette entries}
fCount := Size div 3;
Fillchar(palEntries, sizeof(palEntries), #0);
palEntries.palVersion := $300;
palEntries.palNumEntries := fCount;
PalColor := Data;
FOR j := 0 TO fCount - 1 DO
with palEntries.palPalEntry[j] do
begin
peRed := Owner.GammaTable[PalColor.r];
peGreen := Owner.GammaTable[PalColor.g];
peBlue := Owner.GammaTable[PalColor.b];
peFlags := 0;
{Move to next palette entry}
inc(PalColor);
end;
Owner.SetPalette(CreatePalette(pLogPalette(@palEntries)^));
end;
{Saves the PLTE chunk to a stream}
function TChunkPLTE.SaveToStream(Stream: TStream): Boolean;
var
J: Integer;
DataPtr: pByte;
BitmapInfo: TMAXBITMAPINFO;
palEntries: TMaxLogPalette;
begin
{Adjust size to hold all the palette items}
if fCount = 0 then fCount := Header.BitmapInfo.bmiHeader.biClrUsed;
ResizeData(fCount * 3);
{Get all the palette entries}
fillchar(palEntries, sizeof(palEntries), #0);
GetPaletteEntries(Header.ImagePalette, 0, 256, palEntries.palPalEntry[0]);
{Copy pointer to data}
DataPtr := fData;
{Copy palette items}
BitmapInfo := Header.BitmapInfo;
FOR j := 0 TO fCount - 1 DO
with palEntries.palPalEntry[j] do
begin
DataPtr^ := Owner.InverseGamma[peRed]; inc(DataPtr);
DataPtr^ := Owner.InverseGamma[peGreen]; inc(DataPtr);
DataPtr^ := Owner.InverseGamma[peBlue]; inc(DataPtr);
end {with BitmapInfo};
{Let ancestor do the rest of the work}
Result := inherited SaveToStream(Stream);
end;
{Assigns from another PLTE chunk}
procedure TChunkPLTE.Assign(Source: TChunk);
begin
{Copy the number of palette items}
if Source is TChunkPLTE then
fCount := TChunkPLTE(Source).fCount
else
Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText);
end;
{TChunkgAMA implementation}
{Assigns from another chunk}
procedure TChunkgAMA.Assign(Source: TChunk);
begin
{Copy the gamma value}
if Source is TChunkgAMA then
Gamma := TChunkgAMA(Source).Gamma
else
Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText);
end;
{Gamma chunk being created}
constructor TChunkgAMA.Create(Owner: TPngObject);
begin
{Call ancestor}
inherited Create(Owner);
Gamma := 1; {Initial value}
end;
{Returns gamma value}
function TChunkgAMA.GetValue: Cardinal;
begin
{Make sure that the size is four bytes}
if DataSize <> 4 then
begin
{Adjust size and returns 1}
ResizeData(4);
Result := 1;
end
{If it's right, read the value}
else Result := Cardinal(ByteSwap(pCardinal(Data)^))
end;
function Power(Base, Exponent: Extended): Extended;
begin
if Exponent = 0.0 then
Result := 1.0 {Math rule}
else if (Base = 0) or (Exponent = 0) then Result := 0
else
Result := Exp(Exponent * Ln(Base));
end;
{Loading the chunk from a stream}
function TChunkgAMA.LoadFromStream(Stream: TStream;
const ChunkName: TChunkName; Size: Integer): Boolean;
var
i: Integer;
Value: Cardinal;
begin
{Call ancestor and test if it went ok}
Result := inherited LoadFromStream(Stream, ChunkName, Size);
if not Result then exit;
Value := Gamma;
{Build gamma table and inverse table for saving}
if Value <> 0 then
with Owner do
FOR i := 0 TO 255 DO
begin
GammaTable[I] := Round(Power((I / 255), 1 /
(Value / 100000 * 2.2)) * 255);
InverseGamma[Round(Power((I / 255), 1 /
(Value / 100000 * 2.2)) * 255)] := I;
end
end;
{Sets the gamma value}
procedure TChunkgAMA.SetValue(const Value: Cardinal);
begin
{Make sure that the size is four bytes}
if DataSize <> 4 then ResizeData(4);
{If it's right, set the value}
pCardinal(Data)^ := ByteSwap(Value);
end;
{TPngObject implementation}
{Assigns from another object}
procedure TPngObject.Assign(Source: TPersistent);
begin
{Being cleared}
if Source = nil then
ClearChunks
{Assigns contents from another TPNGObject}
else if Source is TPNGObject then
AssignPNG(Source as TPNGObject)
{Copy contents from a TBitmap}
{$IFDEF UseDelphi}else if Source is TBitmap then
with Source as TBitmap do
AssignHandle(Handle, Transparent,
ColorToRGB(TransparentColor)){$ENDIF}
{Unknown source, let ancestor deal with it}
else
inherited;
end;
{Clear all the chunks in the list}
procedure TPngObject.ClearChunks;
var
i: Integer;
begin
{Initialize gamma}
InitializeGamma();
{Free all the objects and memory (0 chunks Bug fixed by Noel Sharpe)}
for i := 0 TO Integer(Chunks.Count) - 1 do
TChunk(Chunks.Item[i]).Free;
Chunks.Count := 0;
end;
{Portable Network Graphics object being created as a blank image}
constructor TPNGObject.CreateBlank(ColorType, BitDepth: Cardinal;
cx, cy: Integer);
var NewIHDR: TChunkIHDR;
begin
{Calls creator}
Create;
{Checks if the parameters are ok}
if not (ColorType in [COLOR_GRAYSCALE, COLOR_RGB, COLOR_PALETTE,
COLOR_GRAYSCALEALPHA, COLOR_RGBALPHA]) or not (BitDepth in
[1,2,4,8, 16]) or ((ColorType = COLOR_PALETTE) and (BitDepth = 16)) or
((ColorType = COLOR_RGB) and (BitDepth < 8)) then
begin
RaiseError(EPNGInvalidSpec, EInvalidSpec);
exit;
end;
if Bitdepth = 2 then Bitdepth := 4;
{Add the basis chunks}
InitializeGamma;
BeingCreated := True;
Chunks.Add(TChunkIEND);
NewIHDR := Chunks.Add(TChunkIHDR) as TChunkIHDR;
NewIHDR.IHDRData.ColorType := ColorType;
NewIHDR.IHDRData.BitDepth := BitDepth;
NewIHDR.IHDRData.Width := cx;
NewIHDR.IHDRData.Height := cy;
NewIHDR.PrepareImageData;
if NewIHDR.HasPalette then
TChunkPLTE(Chunks.Add(TChunkPLTE)).fCount := 1 shl BitDepth;
Chunks.Add(TChunkIDAT);
BeingCreated := False;
end;
{Portable Network Graphics object being created}
constructor TPngObject.Create;
begin
{Let it be created}
inherited Create;
{Initial properties}
{$IFDEF UseDelphi}fCanvas := TCanvas.Create;{$ENDIF}
fFilters := [pfSub];
fCompressionLevel := 7;
fInterlaceMethod := imNone;
fMaxIdatSize := High(Word);
{Create chunklist object}
fChunkList := TPngList.Create(Self);
end;
{Portable Network Graphics object being destroyed}
destructor TPngObject.Destroy;
begin
{Free object list}
ClearChunks;
fChunkList.Free;
{$IFDEF UseDelphi}if fCanvas <> nil then
fCanvas.Free;{$ENDIF}
{Call ancestor destroy}
inherited Destroy;
end;
{Returns linesize and byte offset for pixels}
procedure TPngObject.GetPixelInfo(var LineSize, Offset: Cardinal);
begin
{There must be an Header chunk to calculate size}
if HeaderPresent then
begin
{Calculate number of bytes for each line}
LineSize := BytesForPixels(Header.Width, Header.ColorType, Header.BitDepth);
{Calculates byte offset}
Case Header.ColorType of
{Grayscale}
COLOR_GRAYSCALE:
If Header.BitDepth = 16 Then
Offset := 2
Else
Offset := 1 ;
{It always smaller or equal one byte, so it occupes one byte}
COLOR_PALETTE:
offset := 1;
{It might be 3 or 6 bytes}
COLOR_RGB:
offset := 3 * Header.BitDepth Div 8;
{It might be 2 or 4 bytes}
COLOR_GRAYSCALEALPHA:
offset := 2 * Header.BitDepth Div 8;
{4 or 8 bytes}
COLOR_RGBALPHA:
offset := 4 * Header.BitDepth Div 8;
else
Offset := 0;
End ;
end
else
begin
{In case if there isn't any Header chunk}
Offset := 0;
LineSize := 0;
end;
end;
{Returns image height}
function TPngObject.GetHeight: Integer;
begin
{There must be a Header chunk to get the size, otherwise returns 0}
if HeaderPresent then
Result := TChunkIHDR(Chunks.Item[0]).Height
else Result := 0;
end;
{Returns image width}
function TPngObject.GetWidth: Integer;
begin
{There must be a Header chunk to get the size, otherwise returns 0}
if HeaderPresent then
Result := Header.Width
else Result := 0;
end;
{Returns if the image is empty}
function TPngObject.GetEmpty: Boolean;
begin
Result := (Chunks.Count = 0);
end;
{Raises an error}
procedure TPngObject.RaiseError(ExceptionClass: ExceptClass; Text: String);
begin
raise ExceptionClass.Create(Text);
end;
{Set the maximum size for IDAT chunk}
procedure TPngObject.SetMaxIdatSize(const Value: Integer);
begin
{Make sure the size is at least 65535}
if Value < High(Word) then
fMaxIdatSize := High(Word) else fMaxIdatSize := Value;
end;
{Draws the image using pixel information from TChunkpHYs}
procedure TPNGObject.DrawUsingPixelInformation(Canvas: TCanvas; Point: TPoint);
function Rect(Left, Top, Right, Bottom: Integer): TRect;
begin
Result.Left := Left;
Result.Top := Top;
Result.Right := Right;
Result.Bottom := Bottom;
end;
var
PPMeterY, PPMeterX: Double;
NewSizeX, NewSizeY: Integer;
DC: HDC;
begin
{Get system information}
DC := GetDC(0);
PPMeterY := GetDeviceCaps(DC, LOGPIXELSY) / 0.0254;
PPMeterX := GetDeviceCaps(DC, LOGPIXELSX) / 0.0254;
ReleaseDC(0, DC);
{In case it does not has pixel information}
if not HasPixelInformation then
Draw(Canvas, Rect(Point.X, Point.Y, Point.X + Width,
Point.Y + Height))
else
with PixelInformation do
begin
NewSizeX := Trunc(Self.Width / (PPUnitX / PPMeterX));
NewSizeY := Trunc(Self.Height / (PPUnitY / PPMeterY));
Draw(Canvas, Rect(Point.X, Point.Y, Point.X + NewSizeX,
Point.Y + NewSizeY));
end;
end;
{$IFNDEF UseDelphi}
{Creates a file stream reading from the filename in the parameter and load}
procedure TPngObject.LoadFromFile(const Filename: String);
var
FileStream: TFileStream;
begin
{Test if the file exists}
if not FileExists(Filename) then
begin
{In case it does not exists, raise error}
RaiseError(EPNGNotExists, EPNGNotExistsText);
exit;
end;
{Creates the file stream to read}
FileStream := TFileStream.Create(Filename, [fsmRead]);
LoadFromStream(FileStream); {Loads the data}
FileStream.Free; {Free file stream}
end;
{Saves the current png image to a file}
procedure TPngObject.SaveToFile(const Filename: String);
var
FileStream: TFileStream;
begin
{Creates the file stream to write}
FileStream := TFileStream.Create(Filename, [fsmWrite]);
SaveToStream(FileStream); {Saves the data}
FileStream.Free; {Free file stream}
end;
{$ENDIF}
{Returns if it has the pixel information chunk}
function TPngObject.HasPixelInformation: Boolean;
begin
Result := (Chunks.ItemFromClass(TChunkpHYs) as tChunkpHYs) <> nil;
end;
{Returns the pixel information chunk}
function TPngObject.GetPixelInformation: TChunkpHYs;
begin
Result := Chunks.ItemFromClass(TChunkpHYs) as tChunkpHYs;
if not Assigned(Result) then
begin
Result := Chunks.Add(tChunkpHYs) as tChunkpHYs;
Result.fUnit := utMeter;
end;
end;
{Returns pointer to the chunk TChunkIHDR which should be the first}
function TPngObject.GetHeader: TChunkIHDR;
begin
{If there is a TChunkIHDR returns it, otherwise returns nil}
if (Chunks.Count <> 0) and (Chunks.Item[0] is TChunkIHDR) then
Result := Chunks.Item[0] as TChunkIHDR
else
begin
{No header, throw error message}
RaiseError(EPNGHeaderNotPresent, EPNGHeaderNotPresentText);
Result := nil
end
end;
{Draws using partial transparency}
procedure TPngObject.DrawPartialTrans(DC: HDC; Rect: TRect);
{Adjust the rectangle structure}
procedure AdjustRect(var Rect: TRect);
var
t: Integer;
begin
if Rect.Right < Rect.Left then
begin
t := Rect.Right;
Rect.Right := Rect.Left;
Rect.Left := t;
end;
if Rect.Bottom < Rect.Top then
begin
t := Rect.Bottom;
Rect.Bottom := Rect.Top;
Rect.Top := t;
end
end;
type
{Access to pixels}
TPixelLine = Array[Word] of TRGBQuad;
pPixelLine = ^TPixelLine;
const
{Structure used to create the bitmap}
BitmapInfoHeader: TBitmapInfoHeader =
(biSize: sizeof(TBitmapInfoHeader);
biWidth: 100;
biHeight: 100;
biPlanes: 1;
biBitCount: 32;
biCompression: BI_RGB;
biSizeImage: 0;
biXPelsPerMeter: 0;
biYPelsPerMeter: 0;
biClrUsed: 0;
biClrImportant: 0);
var
{Buffer bitmap creation}
BitmapInfo : TBitmapInfo;
BufferDC : HDC;
BufferBits : Pointer;
OldBitmap,
BufferBitmap: HBitmap;
Header: TChunkIHDR;
{Transparency/palette chunks}
TransparencyChunk: TChunktRNS;
PaletteChunk: TChunkPLTE;
TransValue, PaletteIndex: Byte;
CurBit: Integer;
Data: PByte;
{Buffer bitmap modification}
BytesPerRowDest,
BytesPerRowSrc,
BytesPerRowAlpha: Integer;
ImageSource, ImageSourceOrg,
AlphaSource : pByteArray;
ImageData : pPixelLine;
i, j, i2, j2 : Integer;
{For bitmap stretching}
W, H : Cardinal;
Stretch : Boolean;
FactorX, FactorY: Double;
begin
{Prepares the rectangle structure to stretch draw}
if (Rect.Right = Rect.Left) or (Rect.Bottom = Rect.Top) then exit;
AdjustRect(Rect);
{Gets the width and height}
W := Rect.Right - Rect.Left;
H := Rect.Bottom - Rect.Top;
Header := Self.Header; {Fast access to header}
Stretch := (W <> Header.Width) or (H <> Header.Height);
if Stretch then FactorX := W / Header.Width else FactorX := 1;
if Stretch then FactorY := H / Header.Height else FactorY := 1;
{Prepare to create the bitmap}
Fillchar(BitmapInfo, sizeof(BitmapInfo), #0);
BitmapInfoHeader.biWidth := W;
BitmapInfoHeader.biHeight := -Integer(H);
BitmapInfo.bmiHeader := BitmapInfoHeader;
{Create the bitmap which will receive the background, the applied}
{alpha blending and then will be painted on the background}
BufferDC := CreateCompatibleDC(0);
{In case BufferDC could not be created}
if (BufferDC = 0) then RaiseError(EPNGOutMemory, EPNGOutMemoryText);
BufferBitmap := CreateDIBSection(BufferDC, BitmapInfo, DIB_RGB_COLORS,
BufferBits, 0, 0);
{In case buffer bitmap could not be created}
if (BufferBitmap = 0) or (BufferBits = Nil) then
begin
if BufferBitmap <> 0 then DeleteObject(BufferBitmap);
DeleteDC(BufferDC);
RaiseError(EPNGOutMemory, EPNGOutMemoryText);
end;
{Selects new bitmap and release old bitmap}
OldBitmap := SelectObject(BufferDC, BufferBitmap);
{Draws the background on the buffer image}
BitBlt(BufferDC, 0, 0, W, H, DC, Rect.Left, Rect.Top, SRCCOPY);
{Obtain number of bytes for each row}
BytesPerRowAlpha := Header.Width;
BytesPerRowDest := (((BitmapInfo.bmiHeader.biBitCount * W) + 31)
and not 31) div 8; {Number of bytes for each image row in destination}
BytesPerRowSrc := (((Header.BitmapInfo.bmiHeader.biBitCount * Header.Width) +
31) and not 31) div 8; {Number of bytes for each image row in source}
{Obtains image pointers}
ImageData := BufferBits;
AlphaSource := Header.ImageAlpha;
Longint(ImageSource) := Longint(Header.ImageData) +
Header.BytesPerRow * Longint(Header.Height - 1);
ImageSourceOrg := ImageSource;
case Header.BitmapInfo.bmiHeader.biBitCount of
{R, G, B images}
24:
FOR j := 1 TO H DO
begin
{Process all the pixels in this line}
FOR i := 0 TO W - 1 DO
begin
if Stretch then i2 := trunc(i / FactorX) else i2 := i;
{Optmize when we don<6F>t have transparency}
if (AlphaSource[i2] <> 0) then
if (AlphaSource[i2] = 255) then
begin
pRGBTriple(@ImageData[i])^ := pRGBTriple(@ImageSource[i2 * 3])^;
ImageData[i].rgbReserved := 255;
end
//ImageData[i] := pRGBQuad(@ImageSource[i2 * 3])^
else
with ImageData[i] do
begin
rgbRed := (255+ImageSource[2+i2*3] * AlphaSource[i2] + rgbRed *
(not AlphaSource[i2])) shr 8;
rgbGreen := (255+ImageSource[1+i2*3] * AlphaSource[i2] +
rgbGreen * (not AlphaSource[i2])) shr 8;
rgbBlue := (255+ImageSource[i2*3] * AlphaSource[i2] + rgbBlue *
(not AlphaSource[i2])) shr 8;
end;
end;
{Move pointers}
inc(Longint(ImageData), BytesPerRowDest);
if Stretch then j2 := trunc(j / FactorY) else j2 := j;
Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2;
Longint(AlphaSource) := Longint(Header.ImageAlpha) +
BytesPerRowAlpha * j2;
end;
{Palette images with 1 byte for each pixel}
1,4,8: if Header.ColorType = COLOR_GRAYSCALEALPHA then
FOR j := 1 TO H DO
begin
{Process all the pixels in this line}
FOR i := 0 TO W - 1 DO
with ImageData[i], Header.BitmapInfo do begin
if Stretch then i2 := trunc(i / FactorX) else i2 := i;
rgbRed := (255 + ImageSource[i2] * AlphaSource[i2] +
rgbRed * (255 - AlphaSource[i2])) shr 8;
rgbGreen := (255 + ImageSource[i2] * AlphaSource[i2] +
rgbGreen * (255 - AlphaSource[i2])) shr 8;
rgbBlue := (255 + ImageSource[i2] * AlphaSource[i2] +
rgbBlue * (255 - AlphaSource[i2])) shr 8;
end;
{Move pointers}
Longint(ImageData) := Longint(ImageData) + BytesPerRowDest;
if Stretch then j2 := trunc(j / FactorY) else j2 := j;
Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2;
Longint(AlphaSource) := Longint(Header.ImageAlpha) +
BytesPerRowAlpha * j2;
end
else {Palette images}
begin
{Obtain pointer to the transparency chunk}
TransparencyChunk := TChunktRNS(Chunks.ItemFromClass(TChunktRNS));
PaletteChunk := TChunkPLTE(Chunks.ItemFromClass(TChunkPLTE));
FOR j := 1 TO H DO
begin
{Process all the pixels in this line}
i := 0;
repeat
CurBit := 0;
if Stretch then i2 := trunc(i / FactorX) else i2 := i;
Data := @ImageSource[i2];
repeat
{Obtains the palette index}
case Header.BitDepth of
1: PaletteIndex := (Data^ shr (7-(I Mod 8))) and 1;
2,4: PaletteIndex := (Data^ shr ((1-(I Mod 2))*4)) and $0F;
else PaletteIndex := Data^;
end;
{Updates the image with the new pixel}
with ImageData[i] do
begin
TransValue := TransparencyChunk.PaletteValues[PaletteIndex];
rgbRed := (255 + PaletteChunk.Item[PaletteIndex].rgbRed *
TransValue + rgbRed * (255 - TransValue)) shr 8;
rgbGreen := (255 + PaletteChunk.Item[PaletteIndex].rgbGreen *
TransValue + rgbGreen * (255 - TransValue)) shr 8;
rgbBlue := (255 + PaletteChunk.Item[PaletteIndex].rgbBlue *
TransValue + rgbBlue * (255 - TransValue)) shr 8;
end;
{Move to next data}
inc(i); inc(CurBit, Header.BitmapInfo.bmiHeader.biBitCount);
until CurBit >= 8;
{Move to next source data}
//inc(Data);
until i >= Integer(W);
{Move pointers}
Longint(ImageData) := Longint(ImageData) + BytesPerRowDest;
if Stretch then j2 := trunc(j / FactorY) else j2 := j;
Longint(ImageSource) := Longint(ImageSourceOrg) - BytesPerRowSrc * j2;
end
end {Palette images}
end {case Header.BitmapInfo.bmiHeader.biBitCount};
{Draws the new bitmap on the foreground}
BitBlt(DC, Rect.Left, Rect.Top, W, H, BufferDC, 0, 0, SRCCOPY);
{Free bitmap}
SelectObject(BufferDC, OldBitmap);
DeleteObject(BufferBitmap);
DeleteDC(BufferDC);
end;
{Draws the image into a canvas}
procedure TPngObject.Draw(ACanvas: TCanvas; const Rect: TRect);
var
Header: TChunkIHDR;
begin
{Quit in case there is no header, otherwise obtain it}
if Empty then Exit;
Header := Chunks.GetItem(0) as TChunkIHDR;
{Copy the data to the canvas}
case Self.TransparencyMode of
{$IFDEF PartialTransparentDraw}
ptmPartial:
DrawPartialTrans(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, Rect);
{$ENDIF}
ptmBit: DrawTransparentBitmap(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF},
Header.ImageData, Header.BitmapInfo.bmiHeader,
pBitmapInfo(@Header.BitmapInfo), Rect,
{$IFDEF UseDelphi}ColorToRGB({$ENDIF}TransparentColor)
{$IFDEF UseDelphi}){$ENDIF}
else
begin
SetStretchBltMode(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, COLORONCOLOR);
StretchDiBits(ACanvas{$IFDEF UseDelphi}.Handle{$ENDIF}, Rect.Left,
Rect.Top, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top, 0, 0,
Header.Width, Header.Height, Header.ImageData,
pBitmapInfo(@Header.BitmapInfo)^, DIB_RGB_COLORS, SRCCOPY)
end
end {case}
end;
{Characters for the header}
const
PngHeader: Array[0..7] of Char = (#137, #80, #78, #71, #13, #10, #26, #10);
{Loads the image from a stream of data}
procedure TPngObject.LoadFromStream(Stream: TStream);
var
Header : Array[0..7] of Char;
HasIDAT : Boolean;
{Chunks reading}
ChunkCount : Cardinal;
ChunkLength: Cardinal;
ChunkName : TChunkName;
begin
{Initialize before start loading chunks}
ChunkCount := 0;
ClearChunks();
{Reads the header}
Stream.Read(Header[0], 8);
{Test if the header matches}
if Header <> PngHeader then
begin
RaiseError(EPNGInvalidFileHeader, EPNGInvalidFileHeaderText);
Exit;
end;
HasIDAT := FALSE;
Chunks.Count := 10;
{Load chunks}
repeat
inc(ChunkCount); {Increment number of chunks}
if Chunks.Count < ChunkCount then {Resize the chunks list if needed}
Chunks.Count := Chunks.Count + 10;
{Reads chunk length and invert since it is in network order}
{also checks the Read method return, if it returns 0, it}
{means that no bytes was readed, probably because it reached}
{the end of the file}
if Stream.Read(ChunkLength, 4) = 0 then
begin
{In case it found the end of the file here}
Chunks.Count := ChunkCount - 1;
RaiseError(EPNGUnexpectedEnd, EPNGUnexpectedEndText);
end;
ChunkLength := ByteSwap(ChunkLength);
{Reads chunk name}
Stream.Read(Chunkname, 4);
{Here we check if the first chunk is the Header which is necessary}
{to the file in order to be a valid Portable Network Graphics image}
if (ChunkCount = 1) and (ChunkName <> 'IHDR') then
begin
Chunks.Count := ChunkCount - 1;
RaiseError(EPNGIHDRNotFirst, EPNGIHDRNotFirstText);
exit;
end;
{Has a previous IDAT}
if (HasIDAT and (ChunkName = 'IDAT')) or (ChunkName = 'cHRM') then
begin
dec(ChunkCount);
Stream.Seek(ChunkLength + 4, soFromCurrent);
Continue;
end;
{Tell it has an IDAT chunk}
if ChunkName = 'IDAT' then HasIDAT := TRUE;
{Creates object for this chunk}
Chunks.SetItem(ChunkCount - 1, CreateClassChunk(Self, ChunkName));
{Check if the chunk is critical and unknown}
{$IFDEF ErrorOnUnknownCritical}
if (TChunk(Chunks.Item[ChunkCount - 1]).ClassType = TChunk) and
((Byte(ChunkName[0]) AND $20) = 0) and (ChunkName <> '') then
begin
Chunks.Count := ChunkCount;
RaiseError(EPNGUnknownCriticalChunk, EPNGUnknownCriticalChunkText);
end;
{$ENDIF}
{Loads it}
try if not TChunk(Chunks.Item[ChunkCount - 1]).LoadFromStream(Stream,
ChunkName, ChunkLength) then break;
except
Chunks.Count := ChunkCount;
raise;
end;
{Terminates when it reaches the IEND chunk}
until (ChunkName = 'IEND');
{Resize the list to the appropriate size}
Chunks.Count := ChunkCount;
{Check if there is data}
if not HasIDAT then
RaiseError(EPNGNoImageData, EPNGNoImageDataText);
end;
{Changing height is not supported}
procedure TPngObject.SetHeight(Value: Integer);
begin
Resize(Width, Value)
end;
{Changing width is not supported}
procedure TPngObject.SetWidth(Value: Integer);
begin
Resize(Value, Height)
end;
{$IFDEF UseDelphi}
{Saves to clipboard format (thanks to Antoine Pottern)}
procedure TPNGObject.SaveToClipboardFormat(var AFormat: Word;
var AData: THandle; var APalette: HPalette);
begin
with TBitmap.Create do
try
Width := Self.Width;
Height := Self.Height;
Self.Draw(Canvas, Rect(0, 0, Width, Height));
SaveToClipboardFormat(AFormat, AData, APalette);
finally
Free;
end {try}
end;
{Loads data from clipboard}
procedure TPngObject.LoadFromClipboardFormat(AFormat: Word;
AData: THandle; APalette: HPalette);
begin
with TBitmap.Create do
try
LoadFromClipboardFormat(AFormat, AData, APalette);
Self.AssignHandle(Handle, False, 0);
finally
Free;
end {try}
end;
{Returns if the image is transparent}
function TPngObject.GetTransparent: Boolean;
begin
Result := (TransparencyMode <> ptmNone);
end;
{$ENDIF}
{Saving the PNG image to a stream of data}
procedure TPngObject.SaveToStream(Stream: TStream);
var
j: Integer;
begin
{Reads the header}
Stream.Write(PNGHeader[0], 8);
{Write each chunk}
FOR j := 0 TO Chunks.Count - 1 DO
Chunks.Item[j].SaveToStream(Stream)
end;
{Prepares the Header chunk}
procedure BuildHeader(Header: TChunkIHDR; Handle: HBitmap; Info: pBitmap);
var
DC: HDC;
begin
{Set width and height}
Header.Width := Info.bmWidth;
Header.Height := abs(Info.bmHeight);
{Set bit depth}
if Info.bmBitsPixel >= 16 then
Header.BitDepth := 8 else Header.BitDepth := Info.bmBitsPixel;
{Set color type}
if Info.bmBitsPixel >= 16 then
Header.ColorType := COLOR_RGB else Header.ColorType := COLOR_PALETTE;
{Set other info}
Header.CompressionMethod := 0; {deflate/inflate}
Header.InterlaceMethod := 0; {no interlace}
{Prepares bitmap headers to hold data}
Header.PrepareImageData();
{Copy image data}
DC := CreateCompatibleDC(0);
GetDIBits(DC, Handle, 0, Header.Height, Header.ImageData,
pBitmapInfo(@Header.BitmapInfo)^, DIB_RGB_COLORS);
DeleteDC(DC);
end;
{Loads the image from a resource}
procedure TPngObject.LoadFromResourceName(Instance: HInst;
const Name: String);
var
ResStream: TResourceStream;
begin
{Creates an especial stream to load from the resource}
try ResStream := TResourceStream.Create(Instance, Name, RT_RCDATA);
except RaiseError(EPNGCouldNotLoadResource, EPNGCouldNotLoadResourceText);
exit; end;
{Loads the png image from the resource}
try
LoadFromStream(ResStream);
finally
ResStream.Free;
end;
end;
{Loads the png from a resource ID}
procedure TPngObject.LoadFromResourceID(Instance: HInst; ResID: Integer);
begin
LoadFromResourceName(Instance, String(ResID));
end;
{Assigns this tpngobject to another object}
procedure TPngObject.AssignTo(Dest: TPersistent);
{$IFDEF UseDelphi}
function DetectPixelFormat: TPixelFormat;
begin
with Header do
begin
{Always use 24bits for partial transparency}
if TransparencyMode = ptmPartial then
DetectPixelFormat := pf24bit
else
case BitDepth of
{Only supported by COLOR_PALETTE}
1: DetectPixelFormat := pf1bit;
2, 4: DetectPixelFormat := pf4bit;
{8 may be palette or r, g, b values}
8, 16:
case ColorType of
COLOR_RGB, COLOR_GRAYSCALE: DetectPixelFormat := pf24bit;
COLOR_PALETTE: DetectPixelFormat := pf8bit;
else raise Exception.Create('');
end {case ColorFormat of}
else raise Exception.Create('');
end {case BitDepth of}
end {with Header}
end;
var
TRNS: TChunkTRNS;
{$ENDIF}
begin
{If the destination is also a TPNGObject make it assign}
{this one}
if Dest is TPNGObject then
TPNGObject(Dest).AssignPNG(Self)
{$IFDEF UseDelphi}
{In case the destination is a bitmap}
else if (Dest is TBitmap) and HeaderPresent then
begin
{Copies the handle using CopyImage API}
TBitmap(Dest).PixelFormat := DetectPixelFormat;
TBitmap(Dest).Width := Width;
TBitmap(Dest).Height := Height;
TBitmap(Dest).Canvas.Draw(0, 0, Self);
{Copy transparency mode}
if (TransparencyMode = ptmBit) then
begin
TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
TBitmap(Dest).TransparentColor := TRNS.TransparentColor;
TBitmap(Dest).Transparent := True
end {if (TransparencyMode = ptmBit)}
end
else
{Unknown destination kind}
inherited AssignTo(Dest);
{$ENDIF}
end;
{Assigns from a bitmap object}
procedure TPngObject.AssignHandle(Handle: HBitmap; Transparent: Boolean;
TransparentColor: ColorRef);
var
BitmapInfo: Windows.TBitmap;
{Chunks}
Header: TChunkIHDR;
PLTE: TChunkPLTE;
IDAT: TChunkIDAT;
IEND: TChunkIEND;
TRNS: TChunkTRNS;
i: Integer;
palEntries : TMaxLogPalette;
begin
{Obtain bitmap info}
GetObject(Handle, SizeOf(BitmapInfo), @BitmapInfo);
{Clear old chunks and prepare}
ClearChunks();
{Create the chunks}
Header := TChunkIHDR.Create(Self);
{This method will fill the Header chunk with bitmap information}
{and copy the image data}
BuildHeader(Header, Handle, @BitmapInfo);
if Header.HasPalette then PLTE := TChunkPLTE.Create(Self) else PLTE := nil;
if Transparent then TRNS := TChunkTRNS.Create(Self) else TRNS := nil;
IDAT := TChunkIDAT.Create(Self);
IEND := TChunkIEND.Create(Self);
{Add chunks}
TPNGPointerList(Chunks).Add(Header);
if Header.HasPalette then TPNGPointerList(Chunks).Add(PLTE);
if Transparent then TPNGPointerList(Chunks).Add(TRNS);
TPNGPointerList(Chunks).Add(IDAT);
TPNGPointerList(Chunks).Add(IEND);
{In case there is a image data, set the PLTE chunk fCount variable}
{to the actual number of palette colors which is 2^(Bits for each pixel)}
if Header.HasPalette then
begin
PLTE.fCount := 1 shl BitmapInfo.bmBitsPixel;
{Create and set palette}
fillchar(palEntries, sizeof(palEntries), 0);
palEntries.palVersion := $300;
palEntries.palNumEntries := 1 shl BitmapInfo.bmBitsPixel;
for i := 0 to palEntries.palNumEntries - 1 do
begin
palEntries.palPalEntry[i].peRed := Header.BitmapInfo.bmiColors[i].rgbRed;
palEntries.palPalEntry[i].peGreen := Header.BitmapInfo.bmiColors[i].rgbGreen;
palEntries.palPalEntry[i].peBlue := Header.BitmapInfo.bmiColors[i].rgbBlue;
end;
DoSetPalette(CreatePalette(pLogPalette(@palEntries)^), false);
end;
{In case it is a transparent bitmap, prepares it}
if Transparent then TRNS.TransparentColor := TransparentColor;
end;
{Assigns from another PNG}
procedure TPngObject.AssignPNG(Source: TPNGObject);
var
J: Integer;
begin
{Copy properties}
InterlaceMethod := Source.InterlaceMethod;
MaxIdatSize := Source.MaxIdatSize;
CompressionLevel := Source.CompressionLevel;
Filters := Source.Filters;
{Clear old chunks and prepare}
ClearChunks();
Chunks.Count := Source.Chunks.Count;
{Create chunks and makes a copy from the source}
if Chunks.Count > 0 then
FOR J := 0 TO Chunks.Count - 1 DO
with Source.Chunks do
begin
Chunks.SetItem(J, TChunkClass(TChunk(Item[J]).ClassType).Create(Self));
TChunk(Chunks.Item[J]).Assign(TChunk(Item[J]));
end {with};
end;
{Returns a alpha data scanline}
function TPngObject.GetAlphaScanline(const LineIndex: Integer): pByteArray;
begin
with Header do
if (ColorType = COLOR_RGBALPHA) or (ColorType = COLOR_GRAYSCALEALPHA) then
Longint(Result) := Longint(ImageAlpha) + (LineIndex * Longint(Width))
else Result := nil; {In case the image does not use alpha information}
end;
{$IFDEF Store16bits}
{Returns a png data extra scanline}
function TPngObject.GetExtraScanline(const LineIndex: Integer): Pointer;
begin
with Header do
Longint(Result) := (Longint(ExtraImageData) + ((Longint(Height) - 1) *
BytesPerRow)) - (LineIndex * BytesPerRow);
end;
{$ENDIF}
{Returns a png data scanline}
function TPngObject.GetScanline(const LineIndex: Integer): Pointer;
begin
with Header do
Longint(Result) := (Longint(ImageData) + ((Longint(Height) - 1) *
BytesPerRow)) - (LineIndex * BytesPerRow);
end;
{Initialize gamma table}
procedure TPngObject.InitializeGamma;
var
i: Integer;
begin
{Build gamma table as if there was no gamma}
FOR i := 0 to 255 do
begin
GammaTable[i] := i;
InverseGamma[i] := i;
end {for i}
end;
{Returns the transparency mode used by this png}
function TPngObject.GetTransparencyMode: TPNGTransparencyMode;
var
TRNS: TChunkTRNS;
begin
with Header do
begin
Result := ptmNone; {Default result}
{Gets the TRNS chunk pointer}
TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
{Test depending on the color type}
case ColorType of
{This modes are always partial}
COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA: Result := ptmPartial;
{This modes support bit transparency}
COLOR_RGB, COLOR_GRAYSCALE: if TRNS <> nil then Result := ptmBit;
{Supports booth translucid and bit}
COLOR_PALETTE:
{A TRNS chunk must be present, otherwise it won't support transparency}
if TRNS <> nil then
if TRNS.BitTransparency then
Result := ptmBit else Result := ptmPartial
end {case}
end {with Header}
end;
{Add a text chunk}
procedure TPngObject.AddtEXt(const Keyword, Text: String);
var
TextChunk: TChunkTEXT;
begin
TextChunk := Chunks.Add(TChunkText) as TChunkTEXT;
TextChunk.Keyword := Keyword;
TextChunk.Text := Text;
end;
{Add a text chunk}
procedure TPngObject.AddzTXt(const Keyword, Text: String);
var
TextChunk: TChunkzTXt;
begin
TextChunk := Chunks.Add(TChunkzTXt) as TChunkzTXt;
TextChunk.Keyword := Keyword;
TextChunk.Text := Text;
end;
{Removes the image transparency}
procedure TPngObject.RemoveTransparency;
var
TRNS: TChunkTRNS;
begin
{Removes depending on the color type}
with Header do
case ColorType of
{Palette uses the TChunktRNS to store alpha}
COLOR_PALETTE:
begin
TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
if TRNS <> nil then Chunks.RemoveChunk(TRNS)
end;
{Png allocates different memory space to hold alpha information}
{for these types}
COLOR_GRAYSCALEALPHA, COLOR_RGBALPHA:
begin
{Transform into the appropriate color type}
if ColorType = COLOR_GRAYSCALEALPHA then
ColorType := COLOR_GRAYSCALE
else ColorType := COLOR_RGB;
{Free the pointer data}
if ImageAlpha <> nil then FreeMem(ImageAlpha);
ImageAlpha := nil
end
end
end;
{Generates alpha information}
procedure TPngObject.CreateAlpha;
var
TRNS: TChunkTRNS;
begin
{Generates depending on the color type}
with Header do
case ColorType of
{Png allocates different memory space to hold alpha information}
{for these types}
COLOR_GRAYSCALE, COLOR_RGB:
begin
{Transform into the appropriate color type}
if ColorType = COLOR_GRAYSCALE then
ColorType := COLOR_GRAYSCALEALPHA
else ColorType := COLOR_RGBALPHA;
{Allocates memory to hold alpha information}
GetMem(ImageAlpha, Integer(Width) * Integer(Height));
FillChar(ImageAlpha^, Integer(Width) * Integer(Height), #255);
end;
{Palette uses the TChunktRNS to store alpha}
COLOR_PALETTE:
begin
{Gets/creates TRNS chunk}
if Chunks.ItemFromClass(TChunkTRNS) = nil then
TRNS := Chunks.Add(TChunkTRNS) as TChunkTRNS
else
TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
{Prepares the TRNS chunk}
with TRNS do
begin
ResizeData(256);
Fillchar(PaletteValues[0], 256, 255);
fDataSize := 1 shl Header.BitDepth;
fBitTransparency := False
end {with Chunks.Add};
end;
end {case Header.ColorType}
end;
{Returns transparent color}
function TPngObject.GetTransparentColor: TColor;
var
TRNS: TChunkTRNS;
begin
TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
{Reads the transparency chunk to get this info}
if Assigned(TRNS) then Result := TRNS.TransparentColor
else Result := 0
end;
{$OPTIMIZATION OFF}
procedure TPngObject.SetTransparentColor(const Value: TColor);
var
TRNS: TChunkTRNS;
begin
if HeaderPresent then
{Tests the ColorType}
case Header.ColorType of
{Not allowed for this modes}
COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA: Self.RaiseError(
EPNGCannotChangeTransparent, EPNGCannotChangeTransparentText);
{Allowed}
COLOR_PALETTE, COLOR_RGB, COLOR_GRAYSCALE:
begin
TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS;
if not Assigned(TRNS) then TRNS := Chunks.Add(TChunkTRNS) as TChunkTRNS;
{Sets the transparency value from TRNS chunk}
TRNS.TransparentColor := {$IFDEF UseDelphi}ColorToRGB({$ENDIF}Value
{$IFDEF UseDelphi}){$ENDIF}
end {COLOR_PALETTE, COLOR_RGB, COLOR_GRAYSCALE)}
end {case}
end;
{Returns if header is present}
function TPngObject.HeaderPresent: Boolean;
begin
Result := ((Chunks.Count <> 0) and (Chunks.Item[0] is TChunkIHDR))
end;
{Returns pixel for png using palette and grayscale}
function GetByteArrayPixel(const png: TPngObject; const X, Y: Integer): TColor;
var
ByteData: Byte;
DataDepth: Byte;
begin
with png, Header do
begin
{Make sure the bitdepth is not greater than 8}
DataDepth := BitDepth;
if DataDepth > 8 then DataDepth := 8;
{Obtains the byte containing this pixel}
ByteData := pByteArray(png.Scanline[Y])^[X div (8 div DataDepth)];
{Moves the bits we need to the right}
ByteData := (ByteData shr ((8 - DataDepth) -
(X mod (8 div DataDepth)) * DataDepth));
{Discard the unwanted pixels}
ByteData:= ByteData and ($FF shr (8 - DataDepth));
{For palette mode map the palette entry and for grayscale convert and
returns the intensity}
case ColorType of
COLOR_PALETTE:
with TChunkPLTE(png.Chunks.ItemFromClass(TChunkPLTE)).Item[ByteData] do
Result := rgb(GammaTable[rgbRed], GammaTable[rgbGreen],
GammaTable[rgbBlue]);
COLOR_GRAYSCALE:
begin
if BitDepth = 1
then ByteData := GammaTable[Byte(ByteData * 255)]
else ByteData := GammaTable[Byte(ByteData * ((1 shl DataDepth) + 1))];
Result := rgb(ByteData, ByteData, ByteData);
end;
else Result := 0;
end {case};
end {with}
end;
{In case vcl units are not being used}
{$IFNDEF UseDelphi}
function ColorToRGB(const Color: TColor): COLORREF;
begin
Result := Color
end;
{$ENDIF}
{Sets a pixel for grayscale and palette pngs}
procedure SetByteArrayPixel(const png: TPngObject; const X, Y: Integer;
const Value: TColor);
const
ClearFlag: Array[1..8] of Integer = (1, 3, 0, 15, 0, 0, 0, $FF);
var
ByteData: pByte;
DataDepth: Byte;
ValEntry: Byte;
begin
with png.Header do
begin
{Map into a palette entry}
ValEntry := GetNearestPaletteIndex(Png.Palette, ColorToRGB(Value));
{16 bits grayscale extra bits are discarted}
DataDepth := BitDepth;
if DataDepth > 8 then DataDepth := 8;
{Gets a pointer to the byte we intend to change}
ByteData := @pByteArray(png.Scanline[Y])^[X div (8 div DataDepth)];
{Clears the old pixel data}
ByteData^ := ByteData^ and not (ClearFlag[DataDepth] shl ((8 - DataDepth) -
(X mod (8 div DataDepth)) * DataDepth));
{Setting the new pixel}
ByteData^ := ByteData^ or (ValEntry shl ((8 - DataDepth) -
(X mod (8 div DataDepth)) * DataDepth));
end {with png.Header}
end;
{Returns pixel when png uses RGB}
function GetRGBLinePixel(const png: TPngObject;
const X, Y: Integer): TColor;
begin
with pRGBLine(png.Scanline[Y])^[X] do
Result := RGB(rgbtRed, rgbtGreen, rgbtBlue)
end;
{Sets pixel when png uses RGB}
procedure SetRGBLinePixel(const png: TPngObject;
const X, Y: Integer; Value: TColor);
begin
with pRGBLine(png.Scanline[Y])^[X] do
begin
rgbtRed := GetRValue(Value);
rgbtGreen := GetGValue(Value);
rgbtBlue := GetBValue(Value)
end
end;
{Returns pixel when png uses grayscale}
function GetGrayLinePixel(const png: TPngObject;
const X, Y: Integer): TColor;
var
B: Byte;
begin
B := PByteArray(png.Scanline[Y])^[X];
Result := RGB(B, B, B);
end;
{Sets pixel when png uses grayscale}
procedure SetGrayLinePixel(const png: TPngObject;
const X, Y: Integer; Value: TColor);
begin
PByteArray(png.Scanline[Y])^[X] := GetRValue(Value);
end;
{Resizes the PNG image}
procedure TPngObject.Resize(const CX, CY: Integer);
function Min(const A, B: Integer): Integer;
begin
if A < B then Result := A else Result := B;
end;
var
Header: TChunkIHDR;
Line, NewBytesPerRow: Integer;
NewHandle: HBitmap;
NewDC: HDC;
NewImageData: Pointer;
NewImageAlpha: Pointer;
NewImageExtra: Pointer;
begin
if (CX > 0) and (CY > 0) then
begin
{Gets some actual information}
Header := Self.Header;
{Creates the new image}
NewDC := CreateCompatibleDC(Header.ImageDC);
Header.BitmapInfo.bmiHeader.biWidth := cx;
Header.BitmapInfo.bmiHeader.biHeight := cy;
NewHandle := CreateDIBSection(NewDC, pBitmapInfo(@Header.BitmapInfo)^,
DIB_RGB_COLORS, NewImageData, 0, 0);
SelectObject(NewDC, NewHandle);
{$IFDEF UseDelphi}Canvas.Handle := NewDC;{$ENDIF}
NewBytesPerRow := (((Header.BitmapInfo.bmiHeader.biBitCount * cx) + 31)
and not 31) div 8;
{Copies the image data}
for Line := 0 to Min(CY - 1, Height - 1) do
CopyMemory(Ptr(Longint(NewImageData) + (Longint(CY) - 1) *
NewBytesPerRow - (Line * NewBytesPerRow)), Scanline[Line],
Min(NewBytesPerRow, Header.BytesPerRow));
{Build array for alpha information, if necessary}
if (Header.ColorType = COLOR_RGBALPHA) or
(Header.ColorType = COLOR_GRAYSCALEALPHA) then
begin
GetMem(NewImageAlpha, CX * CY);
Fillchar(NewImageAlpha^, CX * CY, 255);
for Line := 0 to Min(CY - 1, Height - 1) do
CopyMemory(Ptr(Longint(NewImageAlpha) + (Line * CX)),
AlphaScanline[Line], Min(CX, Width));
FreeMem(Header.ImageAlpha);
Header.ImageAlpha := NewImageAlpha;
end;
{$IFDEF Store16bits}
if (Header.BitDepth = 16) then
begin
GetMem(NewImageExtra, CX * CY);
Fillchar(NewImageExtra^, CX * CY, 0);
for Line := 0 to Min(CY - 1, Height - 1) do
CopyMemory(Ptr(Longint(NewImageExtra) + (Line * CX)),
ExtraScanline[Line], Min(CX, Width));
FreeMem(Header.ExtraImageData);
Header.ExtraImageData := NewImageExtra;
end;
{$ENDIF}
{Deletes the old image}
DeleteObject(Header.ImageHandle);
DeleteDC(Header.ImageDC);
{Prepares the header to get the new image}
Header.BytesPerRow := NewBytesPerRow;
Header.IHDRData.Width := CX;
Header.IHDRData.Height := CY;
Header.ImageData := NewImageData;
{Replaces with the new image}
Header.ImageHandle := NewHandle;
Header.ImageDC := NewDC;
end
else
{The new size provided is invalid}
RaiseError(EPNGInvalidNewSize, EInvalidNewSize)
end;
{Sets a pixel}
procedure TPngObject.SetPixels(const X, Y: Integer; const Value: TColor);
begin
if ((X >= 0) and (X <= Width - 1)) and
((Y >= 0) and (Y <= Height - 1)) then
with Header do
begin
if ColorType in [COLOR_GRAYSCALE, COLOR_PALETTE] then
SetByteArrayPixel(Self, X, Y, Value)
else if ColorType in [COLOR_GRAYSCALEALPHA] then
SetGrayLinePixel(Self, X, Y, Value)
else
SetRGBLinePixel(Self, X, Y, Value)
end {with}
end;
{Returns a pixel}
function TPngObject.GetPixels(const X, Y: Integer): TColor;
begin
if ((X >= 0) and (X <= Width - 1)) and
((Y >= 0) and (Y <= Height - 1)) then
with Header do
begin
if ColorType in [COLOR_GRAYSCALE, COLOR_PALETTE] then
Result := GetByteArrayPixel(Self, X, Y)
else if ColorType in [COLOR_GRAYSCALEALPHA] then
Result := GetGrayLinePixel(Self, X, Y)
else
Result := GetRGBLinePixel(Self, X, Y)
end {with}
else Result := 0
end;
{Returns the image palette}
function TPngObject.GetPalette: HPALETTE;
begin
Result := Header.ImagePalette;
end;
{Assigns from another TChunk}
procedure TChunkpHYs.Assign(Source: TChunk);
begin
fPPUnitY := TChunkpHYs(Source).fPPUnitY;
fPPUnitX := TChunkpHYs(Source).fPPUnitX;
fUnit := TChunkpHYs(Source).fUnit;
end;
{Loads the chunk from a stream}
function TChunkpHYs.LoadFromStream(Stream: TStream; const ChunkName: TChunkName;
Size: Integer): Boolean;
begin
{Let ancestor load the data}
Result := inherited LoadFromStream(Stream, ChunkName, Size);
if not Result or (Size <> 9) then exit; {Size must be 9}
{Reads data}
fPPUnitX := ByteSwap(pCardinal(Longint(Data))^);
fPPUnitY := ByteSwap(pCardinal(Longint(Data) + 4)^);
fUnit := pUnitType(Longint(Data) + 8)^;
end;
{Saves the chunk to a stream}
function TChunkpHYs.SaveToStream(Stream: TStream): Boolean;
begin
{Update data}
ResizeData(9); {Make sure the size is 9}
pCardinal(Data)^ := ByteSwap(fPPUnitX);
pCardinal(Longint(Data) + 4)^ := ByteSwap(fPPUnitY);
pUnitType(Longint(Data) + 8)^ := fUnit;
{Let inherited save data}
Result := inherited SaveToStream(Stream);
end;
procedure TPngObject.DoSetPalette(Value: HPALETTE; const UpdateColors: boolean);
begin
if (Header.HasPalette) then
begin
{Update the palette entries}
if UpdateColors then
Header.PaletteToDIB(Value);
{Resize the new palette}
SelectPalette(Header.ImageDC, Value, False);
RealizePalette(Header.ImageDC);
{Replaces}
DeleteObject(Header.ImagePalette);
Header.ImagePalette := Value;
end
end;
{Set palette based on a windows palette handle}
procedure TPngObject.SetPalette(Value: HPALETTE);
begin
DoSetPalette(Value, true);
end;
{Returns the library version}
function TPNGObject.GetLibraryVersion: String;
begin
Result := LibraryVersion
end;
initialization
{Initialize}
ChunkClasses := nil;
{crc table has not being computed yet}
crc_table_computed := FALSE;
{Register the necessary chunks for png}
RegisterCommonChunks;
{Registers TPNGObject to use with TPicture}
{$IFDEF UseDelphi}{$IFDEF RegisterGraphic}
if GraphicExtension(TPNGObject) = '' then
TPicture.RegisterFileFormat('PNG', 'Portable Network Graphics', TPNGObject);
{$ENDIF}{$ENDIF}
finalization
{$IFDEF UseDelphi}{$IFDEF RegisterGraphic}
TPicture.UnregisterGraphicClass(TPNGObject);
{$ENDIF}{$ENDIF}
{Free chunk classes}
FreeChunkClassList;
end.
Reference in New Issue Copy Permalink