{ +-------------------------------------------------------------+ } { | | } { | GM-Software | } { | =========== | } { | | } { | Project: All Projects | } { | | } { | Description: PNG Image | } { | Original version written by Gustavo Daud. | } { | | } { | Copyright (C) - 2009 - Gerrit Moeller. | } { | | } { | Source code dstributed under MIT license. | } { | | } { | See: https://www.gm-software.de | } { | | } { +-------------------------------------------------------------+ } {$INCLUDE GMCompilerSettings.inc} unit GMPngImage; interface {$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+} {$HPPEMIT '#pragma link "pngimage.obj"'} //Resolve linkage for C++ uses {$IFDEF JEDIAPI}{$ELSE}Windows,{$ENDIF} GMActiveX, GMIntf, GMZStrm, SysUtils {$IFDEF UseDelphi}, Classes, Graphics, SysUtils{$ENDIF}; const cResTypePngImg = 'PNGIMAGE'; //LibraryVersion = '1.564'; {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)'); // Filters for mode 0 FILTER_NONE = 0; FILTER_SUB = 1; FILTER_UP = 2; FILTER_AVERAGE = 3; FILTER_PAETH = 4; // PNG color modes COLOR_GRAYSCALE = 0; COLOR_RGB = 2; COLOR_PALETTE = 3; COLOR_GRAYSCALEALPHA = 4; COLOR_RGBALPHA = 6; type {$IFNDEF UseDelphi} TColor = ColorRef; TCanvas = THandle; TBitmap = HBitmap; TPersistent = TObject; {$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 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; TPNGTransparencyMode = (ptmNone, ptmBit, ptmPartial); pCardinal = ^Cardinal; pRGBPixel = ^TRGBPixel; TRGBPixel = packed record B, G, R: Byte; end; TByteArray = array[Word] of Byte; pByteArray = ^TByteArray; TGMPngImage = class; pPointerArray = ^TPointerArray; TPointerArray = array[Word] of Pointer; TChunk = class; TChunkClass = class of TChunk; TChunkList = class(TObject) private FOwner: TGMPngImage; FEntries: array of TChunk; function GetItem(const AIndex: LongInt): TChunk; procedure SetItem(const AIndex: LongInt; const AValue: TChunk); function GetCount: LongInt; procedure SetCount(const AValue: LongInt); public constructor Create(const AOwner: TGMPngImage); function FindChunk(const ChunkClass: TChunkClass): TChunk; procedure RemoveChunk(const Chunk: TChunk); overload; procedure Insert(const AChunk: TChunk; const APosition: LongInt); procedure Add(const AChunk: TChunk); function AddByClass(const ChunkClass: TChunkClass): TChunk; function ItemFromClass(ChunkClass: TChunkClass): TChunk; property Item [const Idx: LongInt]: TChunk read GetItem write SetItem; property Owner: TGMPngImage read FOwner; property Count: LongInt read GetCount write SetCount; end; TChunkIHDR = class; TChunkpHYs = class; TInterlaceMethod = (imNone, imAdam7); TCompressionLevel = 0..9; TPNGFilter = (pfNone, pfSub, pfUp, pfAverage, pfPaeth); TPNGFilters = set of TPNGFilter; IGMPngImage = interface(IUnknown) ['{751BBD8E-EB62-4349-B936-AB69527EA497}'] function Obj: TGMPngImage; end; TGMPngImage = class(TGMRefCountedObj, IGMPngImage){$IFDEF UseDelphi}(TGraphic){$ENDIF} protected FInverseGamma: array[Byte] of Byte; {$IFDEF UseDelphi}FCanvas: TCanvas;{$ENDIF} FFilters: TPNGFilters; FCompressionLevel: TCompressionLevel; FMaxIdatSize: LongWord; FInterlaceMethod: TInterlaceMethod; FChunkList: TChunkList; procedure ClearChunks; function HeaderPresent: Boolean; procedure GetPixelInfo(var LineSize, Offset: Cardinal); procedure SetMaxIdatSize(const Value: LongWord); 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); //function GetLibraryVersion: String; procedure InitializeGamma; protected FBeingCreated: Boolean; //function GetSupportsPartialTransparency: Boolean; override; function GetPalette: HPALETTE; {$IFDEF UseDelphi}override;{$ENDIF} procedure SetPalette(Value: HPALETTE); {$IFDEF UseDelphi}override;{$ENDIF} procedure DoSetPalette(Value: HPALETTE; const UpdateColors: Boolean); 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} procedure AssignPNG(Source: TGMPngImage); function GetEmpty: Boolean; {$IFDEF UseDelphi}override; {$ENDIF} function GetHeader: TChunkIHDR; procedure DrawPartialTrans(DC: HDC; Rect: TRect); {$IFDEF UseDelphi} function GetTransparent: Boolean; override; {$ENDIF} function GetPixels(const X, Y: Integer): TColor; virtual; procedure SetPixels(const X, Y: Integer; const Value: TColor); virtual; public GammaTable: array[Byte] of Byte; constructor Create(const ARefLifeTime: Boolean = True); override; constructor CreateBlank(ColorType, Bitdepth: Cardinal; cx, cy: Integer; const ARefLifeTime: Boolean = True); destructor Destroy; override; function Obj: TGMPngImage; procedure Resize(const CX, CY: Integer); procedure CreateAlpha; procedure RemoveTransparency; property TransparentColor: TColor read GetTransparentColor write SetTransparentColor; procedure AddtEXt(const Keyword, Text: AnsiString); procedure AddzTXt(const Keyword, Text: AnsiString); function Size: TPoint; {$IFDEF UseDelphi} procedure SaveToClipboardGMFormat(var AFormat: Word; var AData: THandle; var APalette: HPalette); override; procedure LoadFromClipboardGMFormat(AFormat: Word; AData: THandle; APalette: HPalette); override; {$ENDIF} procedure RaiseError(ExceptionClass: ExceptClass; Text: String); 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); {$IFDEF UseDelphi}property Canvas: TCanvas read FCanvas;{$ENDIF} property Header: TChunkIHDR read GetHeader; property TransparencyMode: TPNGTransparencyMode read GetTransparencyMode; procedure Assign(Source: TPersistent);{$IFDEF UseDelphi}override;{$ENDIF} procedure AssignTo(Dest: TPersistent);{$IFDEF UseDelphi}override;{$ENDIF} procedure AssignHandle(Handle: HBitmap; Transparent: Boolean; TransparentColor: ColorRef); procedure Draw(ACanvas: TCanvas; const Rect: TRect); {$IFDEF UseDelphi}override;{$ENDIF} property Width: Integer read GetWidth; property Height: Integer read GetHeight; property InterlaceMethod: TInterlaceMethod read FInterlaceMethod write FInterlaceMethod; property Filters: TPNGFilters read FFilters write FFilters; property MaxIdatSize: LongWord read FMaxIdatSize write SetMaxIdatSize; property Empty: Boolean read GetEmpty; property CompressionLevel: TCompressionLevel read FCompressionLevel write FCompressionLevel; property Chunks: TChunkList read FChunkList; // {$IFNDEF UseDelphi}procedure LoadFromFile(const Filename: String);{.$ENDIF} // {$IFNDEF UseDelphi}procedure SaveToFile(const Filename: String);{.$ENDIF} procedure LoadFromStream(Stream: IStream); {$IFDEF UseDelphi}override;{$ENDIF} procedure SaveToStream(Stream: IStream); {$IFDEF UseDelphi}override;{$ENDIF} //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; {$IFNDEF UseDelphi}property Palette: HPalette read GetPalette write SetPalette;{$ENDIF} //property Version: String read GetLibraryVersion; end; TChunkName = array[0..3] of AnsiChar; TChunk = class private FData: Pointer; FDataSize: Cardinal; FOwner: TGMPngImage; FName: TChunkName; function GetHeader: TChunkIHDR; function GetIndex: Integer; public property Index: Integer read GetIndex; property Header: TChunkIHDR read GetHeader; procedure ResizeData(const NewSize: Cardinal); property Data: Pointer read FData; property DataSize: Cardinal read FDataSize; procedure Assign(Source: TChunk); virtual; property Owner: TGMPngImage read FOwner; constructor Create(Owner: TGMPngImage); virtual; destructor Destroy; override; function LoadFromStream(Stream: IStream; const ChunkName: TChunkName; Size: Integer): Boolean; virtual; function SaveData(Stream: IStream): Boolean; function SaveToStream(Stream: IStream): Boolean; virtual; end; TChunkIEND = class(TChunk); pIHDRData = ^TIHDRData; TIHDRData = packed record Width, Height: Cardinal; BitDepth, ColorType, CompressionMethod, FilterMethod, InterlaceMethod: Byte; end; TChunkIHDR = class(TChunk) private FImageHandle: HBitmap; FImageDC: HDC; FImagePalette: HPalette; FHasPalette: Boolean; FBitmapInfo: TMaxBitmapInfo; {$IFDEF Store16bits}FExtraImageData: Pointer;{$ENDIF} FImageData: pointer; FImageAlpha: Pointer; FIHDRData: TIHDRData; protected BytesPerRow: Integer; function CreateGrayscalePalette(Bitdepth: Integer): HPalette; procedure PaletteToDIB(Palette: HPalette); procedure PrepareImageData; procedure FreeImageData; public {Access to FImageHandle} property ImageHandleValue: HBitmap read FImageHandle; {Properties} property Width: Cardinal read FIHDRData.Width write FIHDRData.Width; property Height: Cardinal read FIHDRData.Height write FIHDRData.Height; property BitDepth: Byte read FIHDRData.BitDepth write FIHDRData.BitDepth; property ColorType: Byte read FIHDRData.ColorType write FIHDRData.ColorType; property CompressionMethod: Byte read FIHDRData.CompressionMethod write FIHDRData.CompressionMethod; property FilterMethod: Byte read FIHDRData.FilterMethod write FIHDRData.FilterMethod; property InterlaceMethod: Byte read FIHDRData.InterlaceMethod write FIHDRData.InterlaceMethod; function LoadFromStream(Stream: IStream; const ChunkName: TChunkName; Size: Integer): Boolean; override; function SaveToStream(Stream: IStream): Boolean; override; constructor Create(Owner: TGMPngImage); override; destructor Destroy; override; procedure Assign(Source: TChunk); override; property ImageDC_: HDC read FImageDC; end; pUnitType = ^TUnitType; TUnitType = (utUnknown, utMeter); TChunkpHYs = class(TChunk) private FPPUnitX, FPPUnitY: Cardinal; FUnit: TUnitType; public property PPUnitX: Cardinal read FPPUnitX write FPPUnitX; property PPUnitY: Cardinal read FPPUnitY write FPPUnitY; property UnitType: TUnitType read FUnit write FUnit; function LoadFromStream(Stream: IStream; const ChunkName: TChunkName; Size: Integer): Boolean; override; function SaveToStream(Stream: IStream): Boolean; override; procedure Assign(Source: TChunk); override; end; TChunkgAMA = class(TChunk) private function GetValue: Cardinal; procedure SetValue(const Value: Cardinal); public property Gamma: Cardinal read GetValue write SetValue; function LoadFromStream(Stream: IStream; const ChunkName: TChunkName; Size: Integer): Boolean; override; constructor Create(Owner: TGMPngImage); override; procedure Assign(Source: TChunk); override; end; TZStreamRec2 = packed record ZLIB: TZStreamRec; // Additional info Data: Pointer; fStream : IStream; end; TChunkPLTE = class(TChunk) protected FCount: Integer; private function GetPaletteItem(Index: Byte): TRGBQuad; public property Item[Index: Byte]: TRGBQuad read GetPaletteItem; property Count: Integer read FCount; function LoadFromStream(Stream: IStream; const ChunkName: TChunkName; Size: Integer): Boolean; override; function SaveToStream(Stream: IStream): Boolean; override; procedure Assign(Source: TChunk); override; end; TChunktRNS = class(TChunk) private FBitTransparency: Boolean; function GetTransparentColor: ColorRef; procedure SetTransparentColor(const Value: ColorRef); public PaletteValues: array[Byte] of Byte; property BitTransparency: Boolean read FBitTransparency; property TransparentColor: ColorRef read GetTransparentColor write SetTransparentColor; function LoadFromStream(Stream: IStream; const ChunkName: TChunkName; Size: Integer): Boolean; override; function SaveToStream(Stream: IStream): Boolean; override; procedure Assign(Source: TChunk); override; end; TChunkIDAT = class(TChunk) private Header: TChunkIHDR; ImageWidth, ImageHeight: Integer; Row_Bytes, Offset : Cardinal; Encode_Buffer: array[0..5] of pByteArray; Row_Buffer: array[Boolean] of pByteArray; RowUsed: Boolean; EndPos: Integer; procedure FilterRow; function FilterToEncode: Byte; function IDATZlibRead(var ZLIBStream: TZStreamRec2; Buffer: Pointer; Count: LongWord; var EndPos: Integer; var crcfile: Cardinal): Integer; procedure IDATZlibWrite(var ZLIBStream: TZStreamRec2; Buffer: Pointer; const Length: Cardinal); procedure FinishIDATZlib(var ZLIBStream: TZStreamRec2); procedure PreparePalette; protected procedure DecodeInterlacedAdam7(Stream: IStream; var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal); procedure DecodeNonInterlaced(Stream: IStream; var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal); procedure EncodeNonInterlaced(Stream: IStream; var ZLIBStream: TZStreamRec2); procedure EncodeInterlacedAdam7(Stream: IStream; var ZLIBStream: TZStreamRec2); // Memory copy methods to decode procedure CopyNonInterlacedRGB8(Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyNonInterlacedRGB16(Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyNonInterlacedPalette148(Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyNonInterlacedPalette2(Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyNonInterlacedGray2(Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyNonInterlacedGrayscale16(Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyNonInterlacedRGBAlpha8(Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyNonInterlacedRGBAlpha16(Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyNonInterlacedGrayscaleAlpha8(Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyNonInterlacedGrayscaleAlpha16(Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyInterlacedRGB8(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyInterlacedRGB16(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyInterlacedPalette148(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyInterlacedPalette2(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyInterlacedGray2(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyInterlacedGrayscale16(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyInterlacedRGBAlpha8(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyInterlacedRGBAlpha16(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyInterlacedGrayscaleAlpha8(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); procedure CopyInterlacedGrayscaleAlpha16(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); // Memory copy methods to encode procedure EncodeNonInterlacedRGB8(Src, Dest, Trans: pByte); procedure EncodeNonInterlacedRGB16(Src, Dest, Trans: pByte); procedure EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pByte); procedure EncodeNonInterlacedPalette148(Src, Dest, Trans: pByte); procedure EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pByte); procedure EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pByte); procedure EncodeNonInterlacedGrayscaleAlpha8(Src, Dest, Trans: pByte); procedure EncodeNonInterlacedGrayscaleAlpha16(Src, Dest, Trans: pByte); procedure EncodeInterlacedRGB8(const Pass: Byte; Src, Dest, Trans: pByte); procedure EncodeInterlacedRGB16(const Pass: Byte; Src, Dest, Trans: pByte); procedure EncodeInterlacedPalette148(const Pass: Byte; Src, Dest, Trans: pByte); procedure EncodeInterlacedGrayscale16(const Pass: Byte; Src, Dest, Trans: pByte); procedure EncodeInterlacedRGBAlpha8(const Pass: Byte; Src, Dest, Trans: pByte); procedure EncodeInterlacedRGBAlpha16(const Pass: Byte; Src, Dest, Trans: pByte); procedure EncodeInterlacedGrayscaleAlpha8(const Pass: Byte; Src, Dest, Trans: pByte); procedure EncodeInterlacedGrayscaleAlpha16(const Pass: Byte; Src, Dest, Trans: pByte); public function LoadFromStream(Stream: IStream; const ChunkName: TChunkName; Size: Integer): Boolean; override; function SaveToStream(Stream: IStream): Boolean; override; end; // Image last modification chunk TChunktIME = class(TChunk) private FYear: Word; FMonth, FDay, FHour, FMinute, FSecond: Byte; public property Year: Word read FYear write FYear; property Month: Byte read FMonth write FMonth; property Day: Byte read FDay write FDay; property Hour: Byte read FHour write FHour; property Minute: Byte read FMinute write FMinute; property Second: Byte read FSecond write FSecond; function LoadFromStream(Stream: IStream; const ChunkName: TChunkName; Size: Integer): Boolean; override; function SaveToStream(Stream: IStream): Boolean; override; procedure Assign(Source: TChunk); override; end; // Textual data TChunktEXt = class(TChunk) private FKeyword, FText: AnsiString; public property Keyword: AnsiString read FKeyword write FKeyword; property Text: AnsiString read FText write FText; function LoadFromStream(Stream: IStream; const ChunkName: TChunkName; Size: Integer): Boolean; override; function SaveToStream(Stream: IStream): Boolean; override; procedure Assign(Source: TChunk); override; end; {zTXT chunk} TChunkzTXt = class(TChunktEXt) {Loads the chunk from a stream} function LoadFromStream(Stream: IStream; const ChunkName: TChunkName; Size: Integer): Boolean; override; {Saves the chunk to a stream} function SaveToStream(Stream: IStream): 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} function update_crc(crc: {$IFNDEF DelphiBuilder3Less}Cardinal{$ELSE}Integer {$ENDIF}; buf: pByteArray; len: Integer): Cardinal; function ByteSwap(const a: integer): integer; function GMLoadPngImgFromRes(const AResourceName: PChar; AResourceType: PChar = nil; AModuleHandle: THandle = INVALID_HANDLE_VALUE): IGMPngImage; implementation uses GMCommon; resourcestring EPngInvalidCRCText = 'This PNG image is not valid because it contains invalid pieces of data (crc error)'; EPNGInvalidIHDRText = 'The PNG image could not be loaded because one of its main piece of data (ihdr) might be corrupted'; EPNGMissingMultipleIDATText = 'This PNG image is invalid because it has missing image parts'; EPNGZLIBErrorText = 'Could not decompress the image because it contains invalid compressed data.'#13#10 + ' Description: '; EPNGInvalidPaletteText = 'The PNG image contains an invalid palette'; EPNGInvalidFileHeaderText = 'The file being readed is not a valid PNG image because it contains an invalid header. This file may be corruped, try obtaining it again'; EPNGIHDRNotFirstText = 'This PNG image is not supported or it might be invalid.'#13#10 + '(IHDR chunk is not the first)'; EPNGNotExistsText = 'The png file could not be loaded because it does not exists'; EPNGSizeExceedsText = 'This PNG image is not supported because either it''s width or height exceeds the maximum size, which is 65535 pixels length'; EPNGUnknownPalEntryText = 'There is no such palette entry'; EPNGMissingPaletteText = 'This PNG could not be loaded because it uses a color table which is missing'; EPNGUnknownCriticalChunkText = 'This PNG image contains an unknown critical part which could not be decoded'; EPNGUnknownCompressionText = 'This PNG image is encoded with an unknown compression scheme which could not be decoded'; EPNGUnknownInterlaceText = 'This PNG image uses an unknown interlace scheme which could not be decoded'; EPNGCannotAssignChunkText = 'The chunks must be compatible to be assigned'; EPNGUnexpectedEndText = 'This PNG image is invalid because the decoder found an unexpected end of the file'; EPNGNoImageDataText = 'This PNG image contains no data'; EPNGCannotChangeSizeText = 'The PNG image can not be resize by changing width and height properties. Try assigning the image from a bitmap'; EPNGCannotAddChunkText = 'The program tried to add a existent critical chunk to the current image which is not allowed'; EPNGCannotAddInvalidImageText = 'It''s not allowed to add a new chunk because the current image is invalid'; EPNGCouldNotLoadResourceText = 'The png image could not be loaded from the resource ID'; EPNGOutMemoryText = 'Some operation could not be performed because the system is out of resources. Close some windows and try again'; EPNGCannotChangeTransparentText = 'Setting bit transparency color is not allowed for png images containing alpha value for each pixel (COLOR_RGBALPHA and COLOR_GRAYSCALEALPHA)'; EPNGHeaderNotPresentText = 'This operation is not valid because the current image contains no valid header'; EInvalidNewSizeText = 'The new size provided for image resizing is invalid'; EInvalidSpecText = 'The PNG image could not be created because invalid image type parameters have being provided'; var crc_table: array[0..255] of Cardinal; crc_table_computed: Boolean; function GMLoadPngImgFromRes(const AResourceName: PChar; AResourceType: PChar; AModuleHandle: THandle): IGMPngImage; var ResStrm: IStream; begin if AResourceName <> nil then begin if AResourceType = nil then AResourceType := cResTypePngImg; if AModuleHandle = INVALID_HANDLE_VALUE then AModuleHandle := HInstance; ResStrm := TGMResourceIStream.Create(AResourceName, AResourceType, AModuleHandle, True); Result := TGMPngImage.Create(True); Result.Obj.LoadFromStream(ResStrm); end; end; {Draw transparent image using transparent color} procedure DrawTransparentBitmap(dc: HDC; srcBits: Pointer; var srcHeader: TBitmapInfoHeader; srcBitmapInfo: pBitmapInfo; Rect: TRect; cTransparentColor: COLORREF); var cColor: COLORREF; bmpBkgndMask, bmpImageMask, bmAndMem: HBITMAP; bmpOldBkgnd, bmpOldImage, bmpMemOld: HBITMAP; hdcMem, dcBkgndMask, dcImageMask, dcDraw: HDC; ptSize, orgSize: TPOINT; OldBitmap, bmpDraw: HBITMAP; begin dcDraw := CreateCompatibleDC(dc); {Select the bitmap} bmpDraw := CreateDIBitmap(dc, srcHeader, CBM_INIT, srcBits, srcBitmapInfo^, DIB_RGB_COLORS); OldBitmap := SelectObject(dcDraw, bmpDraw); {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} dcBkgndMask := CreateCompatibleDC(dc); dcImageMask := CreateCompatibleDC(dc); hdcMem := CreateCompatibleDC(dc); // Create a bitmap for each DC. DCs are required for a number of // GDI functions. // Monochrome DCs bmpBkgndMask := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil); bmpImageMask := 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. bmpOldBkgnd := SelectObject(dcBkgndMask, bmpBkgndMask); bmpOldImage := SelectObject(dcImageMask, bmpImageMask); bmpMemOld := 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(dcDraw, cTransparentColor); // Create the object mask for the bitmap by performing a BitBlt // from the source bitmap to a monochrome bitmap. StretchBlt(dcImageMask, 0, 0, ptSize.x, ptSize.y, dcDraw, 0, 0, orgSize.x, orgSize.y, SRCCOPY); // Set the background color of the source DC back to the original color. SetBkColor(dcDraw, cColor); // Create the inverse of the object mask. BitBlt(dcBkgndMask, 0, 0, ptSize.x, ptSize.y, dcImageMask, 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, dcImageMask, 0, 0, SRCAND); // Mask out the transparent colored pixels on the bitmap. // BitBlt(dcDraw, 0, 0, ptSize.x, ptSize.y, dcBkgndMask, 0, 0, SRCAND); StretchBlt(dcDraw, 0, 0, OrgSize.x, OrgSize.y, dcBkgndMask, 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, dcDraw, 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(dcBkgndMask, bmpOldBkgnd)); DeleteObject(SelectObject(dcImageMask, bmpOldImage)); DeleteObject(SelectObject(hdcMem, bmpMemOld)); DeleteObject(SelectObject(dcDraw, OldBitmap)); // Delete the memory DCs. DeleteDC(hdcMem); DeleteDC(dcBkgndMask); DeleteDC(dcImageMask); DeleteDC(dcDraw); end; procedure make_crc_table; var c: Cardinal; n, k: Integer; begin for n := 0 to 255 do begin c := Cardinal(n); for k := 0 to 7 do if Boolean(c and 1) then c := $edb88320 xor (c shr 1) else c := c shr 1; crc_table[n] := c; end; 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; if not crc_table_computed then make_crc_table; for n := 0 to len - 1 do c := crc_table[(c XOR buf^[n]) and $FF] XOR (c shr 8); Result := c; end; {$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} {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; function CreateChunkByClass(AOwner: TGMPngImage; AName: TChunkName): TChunk; var ChunkCreateClass: TChunkClass; const cnIEND = Ord('I') + Ord('E') shl 8 + Ord('N') shl 16 + Ord('D') shl 24; const cnIHDR = Ord('I') + Ord('H') shl 8 + Ord('D') shl 16 + Ord('R') shl 24; const cnIDAT = Ord('I') + Ord('D') shl 8 + Ord('A') shl 16 + Ord('T') shl 24; const cnPLTE = Ord('P') + Ord('L') shl 8 + Ord('T') shl 16 + Ord('E') shl 24; const cngAMA = Ord('g') + Ord('A') shl 8 + Ord('M') shl 16 + Ord('A') shl 24; const cntRNS = Ord('t') + Ord('R') shl 8 + Ord('N') shl 16 + Ord('S') shl 24; const cnpHYs = Ord('p') + Ord('H') shl 8 + Ord('Y') shl 16 + Ord('s') shl 24; const cntIME = Ord('t') + Ord('I') shl 8 + Ord('M') shl 16 + Ord('E') shl 24; const cntEXt = Ord('t') + Ord('E') shl 8 + Ord('X') shl 16 + Ord('t') shl 24; const cnzTXt = Ord('z') + Ord('T') shl 8 + Ord('X') shl 16 + Ord('t') shl 24; begin case LongWord(AName) of // Important chunks cnIEND: ChunkCreateClass := TChunkIEND; cnIHDR: ChunkCreateClass := TChunkIHDR; cnIDAT: ChunkCreateClass := TChunkIDAT; cnPLTE: ChunkCreateClass := TChunkPLTE; cngAMA: ChunkCreateClass := TChunkgAMA; cntRNS: ChunkCreateClass := TChunktRNS; // Less important chunks cnpHYs: ChunkCreateClass := TChunkpHYs; cntIME: ChunkCreateClass := TChunktIME; cntEXt: ChunkCreateClass := TChunktEXt; cnzTXt: ChunkCreateClass := TChunkzTXt; else ChunkCreateClass := TChunk; // <- default creation end; Result := ChunkCreateClass.Create(AOwner); Result.FName := AName; end; {ZLIB support} const ZLIBAllocate = High(Word); {Initializes ZLIB for decompression} function ZLIBInitInflate(Stream: IStream): TZStreamRec2; begin Fillchar(Result, SIZEOF(TZStreamRec2), #0); with Result do begin GetMem(Data, ZLIBAllocate); fStream := Stream; end; InflateInit_(Result.zlib, zlib_version, SIZEOF(TZStreamRec)); end; {Initializes ZLIB for compression} function ZLIBInitDeflate(Stream: IStream; Level: TCompressionlevel; Size: Cardinal): TZStreamRec2; begin Fillchar(Result, SIZEOF(TZStreamRec2), #0); with Result, ZLIB do begin GetMem(Data, Size); fStream := Stream; next_out := Data; avail_out := Size; end; deflateInit_(Result.zlib, Level, zlib_version, sizeof(TZStreamRec)); end; {Terminates ZLIB for compression} procedure ZLIBTerminateDeflate(var ZLIBStream: TZStreamRec2); begin {Terminates decompression} DeflateEnd(ZLIBStream.zlib); {Free internal record} FreeMem(ZLIBStream.Data, ZLIBAllocate); end; {Terminates ZLIB for decompression} procedure ZLIBTerminateInflate(var ZLIBStream: TZStreamRec2); begin {Terminates decompression} InflateEnd(ZLIBStream.zlib); {Free internal record} FreeMem(ZLIBStream.Data, ZLIBAllocate); end; {Decompresses ZLIB into a memory address} function DecompressZLIB(const Input: Pointer; InputSize: Integer; var Output: Pointer; var OutputSize: LongWord; 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_version, 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(PtrUInt(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 := string(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: LongWord; 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_version, 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(PtrUInt(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 := string(AnsiString(StreamRec.msg)); DeflateEnd(StreamRec); Exit; end {if InflateRet < 0} end {while avail_in > 0}; {Finishes compressing} DeflateEnd(StreamRec); end {with StreamRec} end; {TChunkList implementation} constructor TChunkList.Create(const AOwner: TGMPngImage); begin inherited Create; FOwner := AOwner; end; {Finds the first chunk of this class} function TChunkList.FindChunk(const 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; function TChunkList.GetCount: LongInt; begin Result := Length(FEntries); end; procedure TChunkList.Insert(const AChunk: TChunk; const APosition: LongInt); begin SetLength(FEntries, Length(FEntries)+1); if APosition <= High(FEntries) then System.Move(FEntries[APosition], FEntries[APosition+1], (Length(FEntries) - APosition -1) * SizeOf(TChunk)); FEntries[APosition] := AChunk; end; procedure TChunkList.Add(const AChunk: TChunk); begin SetLength(FEntries, Length(FEntries)+1); FEntries[High(FEntries)] := AChunk; end; function TChunkList.GetItem(const AIndex: LongInt): TChunk; begin if (AIndex >= Low(FEntries)) and (AIndex <= High(FEntries)) then Result := FEntries[AIndex] else Result := nil; end; procedure TChunkList.SetItem(const AIndex: LongInt; const AValue: TChunk); begin if (AIndex >= Low(FEntries)) and (AIndex <= High(FEntries)) then FEntries[AIndex] := AValue; end; procedure TChunkList.SetCount(const AValue: LongInt); begin SetLength(FEntries, Length(FEntries) + 1); end; procedure TChunkList.RemoveChunk(const Chunk: TChunk); var i: LongInt; begin if Length(FEntries) = 0 then Exit; for i := Low(FEntries) to High(FEntries) do if Chunk = FEntries[i] then Break; if Chunk <> FEntries[i] then Exit; if i < High(FEntries) then System.Move(FEntries[i+1], FEntries[i], (Length(FEntries) - i-1) * SizeOf(TChunk)); SetLength(FEntries, Length(FEntries)-1); Chunk.Free; end; function TChunkList.AddByClass(const 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.FBeingCreated) 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.FBeingCreated 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; function TChunkList.ItemFromClass(ChunkClass: TChunkClass): TChunk; // Returns first item from the list using the class from parameter var i: Integer; begin Result := nil; {Initial Result} 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; {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; constructor TChunk.Create(Owner: TGMPngImage); var ChunkName: AnsiString; begin 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 := AnsiString(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; destructor TChunk.Destroy; begin FreeMem(FData, FDataSize + 1); inherited Destroy; end; function TChunk.SaveData(Stream: IStream): Boolean; var ChunkSize, ChunkCRC: Cardinal; begin {First, write the size for the following data in the chunk} ChunkSize := ByteSwap(DataSize); GMSafeIStreamWrite(Stream, @ChunkSize, SizeOf(ChunkSize)); {The chunk name} GMSafeIStreamWrite(Stream, @FName, SizeOf(FName)); {If there is data for the chunk, write it} if DataSize > 0 then GMSafeIStreamWrite(Stream, Data, DataSize); {Calculates and write CRC} ChunkCRC := update_crc($ffffffff, @FName[0], SizeOf(FName)); ChunkCRC := Byteswap(update_crc(ChunkCRC, Data, DataSize) xor $ffffffff); GMSafeIStreamWrite(Stream, @ChunkCRC, SizeOf(ChunkCRC)); {Returns that everything went ok} Result := TRUE; end; function TChunk.SaveToStream(Stream: IStream): Boolean; begin Result := SaveData(Stream) end; function TChunk.LoadFromStream(Stream: IStream; 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 GMSafeIStreamRead(Stream, FData, Size); {Reads CRC} GMSafeIStreamRead(Stream, @CheckCRC, SizeOf(CheckCRC)); CheckCrc := ByteSwap(CheckCRC); {Check if crc readed is valid} {$IFDEF CheckCRC} RightCRC := update_crc($ffffffff, @ChunkName[0], SizeOf(ChunkName)); 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: IStream; 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: IStream): 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: IStream; const ChunkName: TChunkName; Size: Integer): Boolean; var ErrorOutput: String; CompressionMethod: Byte; Output: Pointer; OutputSize: LongWord; begin {Load data from stream and validate} Result := inherited LoadFromStream(Stream, ChunkName, Size); if not Result or (Size < 4) then Exit; FKeyword := PAnsiChar(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(PAnsiChar(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: IStream): Boolean; var Output: Pointer; OutputSize: LongWord; 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(Cardinal(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: IStream; 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 := PAnsiChar(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: IStream): 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: TGMPngImage); begin {Prepare pointers} FImageHandle := 0; FImagePalette := 0; FImageDC := 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} FIHDRData := TChunkIHDR(Source).FIHDRData; {Prepare to hold data by filling FBitmapInfo structure and} {resizing FImageData and FImageAlpha memory allocations} PrepareImageData(); {Copy image data} CopyMemory(FImageData, TChunkIHDR(Source).FImageData, BytesPerRow * Integer(Height)); CopyMemory(FImageAlpha, TChunkIHDR(Source).FImageAlpha, Integer(Width) * Integer(Height)); {Copy palette colors} FBitmapInfo.bmiColors := TChunkIHDR(Source).FBitmapInfo.bmiColors; {Copy palette also} CopyPalette(TChunkIHDR(Source).FImagePalette, FImagePalette); end else Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText); end; {Release allocated image data} procedure TChunkIHDR.FreeImageData; begin {Free old image data} if FImageHandle <> 0 then DeleteObject(FImageHandle); if FImageDC <> 0 then DeleteDC(FImageDC); if FImageAlpha <> nil then FreeMem(FImageAlpha); if FImagePalette <> 0 then DeleteObject(FImagePalette); {$IFDEF Store16bits} if FExtraImageData <> nil then FreeMem(FExtraImageData); {$ENDIF} FImageHandle := 0; FImageDC := 0; FImageAlpha := nil; FImageData := nil; FImagePalette := 0; FExtraImageData := nil; end; {Chunk being loaded from a stream} function TChunkIHDR.LoadFromStream(Stream: IStream; 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} FIHDRData := pIHDRData(FData)^; FIHDRData.Width := ByteSwap(FIHDRData.Width); FIHDRData.Height := ByteSwap(FIHDRData.Height); {The width and height must not be larger than 65535 pixels} if (FIHDRData.Width > High(Word)) or (FIHDRData.Height > High(Word)) then begin Result := False; Owner.RaiseError(EPNGSizeExceeds, EPNGSizeExceedsText); Exit; end {if FIHDRData.Width > High(Word)}; {Compression method must be 0 (inflate/deflate)} if (FIHDRData.CompressionMethod <> 0) then begin Result := False; Owner.RaiseError(EPNGUnknownCompression, EPNGUnknownCompressionText); Exit; end; {Interlace must be either 0 (none) or 7 (adam7)} if (FIHDRData.InterlaceMethod <> 0) and (FIHDRData.InterlaceMethod <> 1) then begin Result := False; Owner.RaiseError(EPNGUnknownInterlace, EPNGUnknownInterlaceText); Exit; end; {Updates owner properties} Owner.InterlaceMethod := TInterlaceMethod(FIHDRData.InterlaceMethod); {Prepares data to hold image} PrepareImageData(); end; {Saving the IHDR chunk to a stream} function TChunkIHDR.SaveToStream(Stream: IStream): 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)^ := FIHDRData; {..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); FBitmapInfo.bmiHeader.biClrUsed := GetPaletteEntries(Palette, 0, 256, palEntries.palPalEntry[0]); for j := 0 to FBitmapInfo.bmiHeader.biClrUsed - 1 do begin FBitmapInfo.bmiColors[j].rgbBlue := palEntries.palPalEntry[j].peBlue; FBitmapInfo.bmiColors[j].rgbRed := palEntries.palPalEntry[j].peRed; FBitmapInfo.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} FHasPalette := Palette; {Fill the strucutre} with FBitmapInfo.bmiHeader do begin biSize := sizeof(TBitmapInfoHeader); biHeight := Height; biWidth := Width; biPlanes := 1; biBitCount := BitDepth; biCompression := BI_RGB; end {with FBitmapInfo.bmiHeader} end; begin {Prepare bitmap info header} Fillchar(FBitmapInfo, 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 := (((FBitmapInfo.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(FImageAlpha, Integer(Width) * Integer(Height)); FillChar(FImageAlpha^, Integer(Width) * Integer(Height), #0); end; {Build array for extra byte information} {$IFDEF Store16bits} if (BitDepth = 16) then begin GetMem(FExtraImageData, BytesPerRow * Integer(Height)); FillChar(FExtraImageData^, BytesPerRow * Integer(Height), #0); end; {$ENDIF} {Creates the image to hold the data, CreateDIBSection does a better} {work in allocating necessary memory} FImageDC := CreateCompatibleDC(0); {$IFDEF UseDelphi}Self.Owner.Canvas.Handle := FImageDC;{$ENDIF} {In case it is a palette image, create the palette} if FHasPalette then begin {Create a standard palette} if ColorType = COLOR_PALETTE then FImagePalette := CreateHalfTonePalette(FImageDC) else FImagePalette := CreateGrayscalePalette(Bitdepth); ResizePalette(FImagePalette, 1 shl FBitmapInfo.bmiHeader.biBitCount); FBitmapInfo.bmiHeader.biClrUsed := 1 shl FBitmapInfo.bmiHeader.biBitCount; SelectPalette(FImageDC, FImagePalette, False); RealizePalette(FImageDC); PaletteTODIB(FImagePalette); end; {Create the device independent bitmap} FImageHandle := CreateDIBSection(FImageDC, pBitmapInfo(@FBitmapInfo)^, DIB_RGB_COLORS, FImageData, 0, 0); SelectObject(FImageDC, FImageHandle); {Build array and allocate bytes for each row} fillchar(FImageData^, 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 FBitmapInfo.bmiHeader.biClrUsed - 1 do if CompareMem(@FBitmapInfo.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 := FBitmapInfo.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: IStream): 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: IStream; 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(FBitmapInfo.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 FBitmapInfo.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: LongWord; var EndPos: Integer; var crcfile: Cardinal): Integer; var ProcResult : Integer; IDATHeader : array[0..3] of AnsiChar; 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 (GMIStreamPos(fStream) = EndPos) and (avail_out > 0) and (avail_in = 0) then begin {End this chunk by reading and testing the crc value} GMSafeIStreamRead(fStream, @IDATCRC, SizeOf(IDATCRC)); {$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} GMSafeIStreamRead(fStream, @EndPos, SizeOf(EndPos)); {Reads next chunk size} GMSafeIStreamRead(fStream, @IDATHeader[0], SizeOf(IDATHeader)); {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], SizeOf(IDATHeader)); {$ENDIF} EndPos := GMIStreamPos(fStream) + 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 GMIStreamPos(fStream) + ZLIBAllocate > EndPos then avail_in := GMIStreamRead(fStream, Data, EndPos - GMIStreamPos(fStream)) else avail_in := GMIStreamRead(fStream, 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}: pByte); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; Dest := pByte(LongInt(Dest) + Col * 3); repeat {Copy this row} PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) + 2)^]; inc(Dest); PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) + 1)^]; inc(Dest); PByte(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}: pByte); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; Dest := pByte(LongInt(Dest) + Col * 3); repeat {Copy this row} PByte(Dest)^ := Owner.GammaTable[pByte(LongInt(Src) + 4)^]; inc(Dest); PByte(Dest)^ := Owner.GammaTable[pByte(LongInt(Src) + 2)^]; inc(Dest); PByte(Dest)^ := Owner.GammaTable[pByte(LongInt(Src) )^]; inc(Dest); {$IFDEF Store16bits} {Copy extra pixel values} PByte(Extra)^ := FOwner.GammaTable[pByte(LongInt(Src) + 5)^]; inc(Extra); PByte(Extra)^ := FOwner.GammaTable[pByte(LongInt(Src) + 3)^]; inc(Extra); PByte(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 �mages with palette using bit depths 1, 4 or 8} procedure TChunkIDAT.CopyInterlacedPalette148(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); 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: pByte; 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 := pByte(LongInt(Dest) + (Header.BitDepth * Col) div 8); {Copy data} PByte(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 �mages with palette using bit depth 2} procedure TChunkIDAT.CopyInterlacedPalette2(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); var CurBit, Col: Integer; Dest2: pByte; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; repeat {Copy data} CurBit := 6; repeat {Adjust pointer to pixel byte bounds} Dest2 := pByte(LongInt(Dest) + Col div 2); {Copy data} PByte(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 �mages with grayscale using bit depth 2} procedure TChunkIDAT.CopyInterlacedGray2(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); var CurBit, Col: Integer; Dest2: pByte; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; repeat {Copy data} CurBit := 6; repeat {Adjust pointer to pixel byte bounds} Dest2 := pByte(LongInt(Dest) + Col div 2); {Copy data} PByte(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 �mages with palette using 2 bytes for each pixel} procedure TChunkIDAT.CopyInterlacedGrayscale16(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; Dest := pByte(LongInt(Dest) + Col); repeat {Copy this row} Dest^ := Src^; inc(Dest); {$IFDEF Store16bits} Extra^ := pByte(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}: pByte); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; Dest := pByte(LongInt(Dest) + Col * 3); Trans := pByte(LongInt(Trans) + Col); repeat {Copy this row and alpha value} Trans^ := pByte(LongInt(Src) + 3)^; PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) + 2)^]; inc(Dest); PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) + 1)^]; inc(Dest); PByte(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}: pByte); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; Dest := pByte(LongInt(Dest) + Col * 3); Trans := pByte(LongInt(Trans) + Col); repeat {Copy this row and alpha value} Trans^ := pByte(LongInt(Src) + 6)^; PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) + 4)^]; inc(Dest); PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) + 2)^]; inc(Dest); PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) )^]; inc(Dest); {$IFDEF Store16bits} {Copy extra pixel values} PByte(Extra)^ := FOwner.GammaTable[pByte(LongInt(Src) + 5)^]; inc(Extra); PByte(Extra)^ := FOwner.GammaTable[pByte(LongInt(Src) + 3)^]; inc(Extra); PByte(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}: pByte); var Col: Integer; begin {Get first column, pointers to the data and enter in loop} Col := ColumnStart[Pass]; Dest := pByte(LongInt(Dest) + Col); Trans := pByte(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}: pByte); var Col: Integer; begin {Get first column, pointers to the data and enter in loop} Col := ColumnStart[Pass]; Dest := pByte(LongInt(Dest) + Col); Trans := pByte(LongInt(Trans) + Col); repeat {$IFDEF Store16bits} Extra^ := pByte(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: IStream; var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal); var CurrentPass: Byte; PixelsThisRow: Integer; CurrentRow: Integer; Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pByte; CopyProc: procedure(const Pass: Byte; Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte) 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.FImageData) + Header.BytesPerRow * (ImageHeight - 1 - CurrentRow)); Trans := Ptr(LongInt(Header.FImageAlpha) + ImageWidth * CurrentRow); {$IFDEF Store16bits} Extra := Ptr(LongInt(Header.FExtraImageData) + 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}: pByte); var I: Integer; begin FOR I := 1 TO ImageWidth DO begin {Copy pixel values} PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) + 2)^]; inc(Dest); PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) + 1)^]; inc(Dest); PByte(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}: pByte); 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} PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) + 4)^]; inc(Dest); PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) + 2)^]; inc(Dest); PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) )^]; inc(Dest); {$IFDEF Store16bits} {Copy extra pixel values} PByte(Extra)^ := FOwner.GammaTable[pByte(LongInt(Src) + 5)^]; inc(Extra); PByte(Extra)^ := FOwner.GammaTable[pByte(LongInt(Src) + 3)^]; inc(Extra); PByte(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}: pByte); 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}: pByte); var i: Integer; begin {2 bits is not supported, this routine will converted into 4 bits} FOR i := 1 TO Row_Bytes do begin PByte(Dest)^ := ((Byte(Src^) shr 2) and $F) or ((Byte(Src^)) and $F0); inc(Dest); PByte(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}: pByte); var i: Integer; begin {2 bits is not supported, this routine will converted into 4 bits} FOR i := 1 TO Row_Bytes do begin PByte(Dest)^ := ((Byte(Src^) shr 4) and $3) or ((Byte(Src^) shr 2) and $30); inc(Dest); PByte(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}: pByte); 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^ := pByte(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}: pByte); var i: Integer; begin FOR I := 1 TO ImageWidth DO begin {Copy pixel values and transparency} Trans^ := pByte(LongInt(Src) + 3)^; PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) + 2)^]; inc(Dest); PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) + 1)^]; inc(Dest); PByte(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}: pByte); 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^ := pByte(LongInt(Src) + 6)^; PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) + 4)^]; inc(Dest); PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) + 2)^]; inc(Dest); PByte(Dest)^ := FOwner.GammaTable[pByte(LongInt(Src) )^]; inc(Dest); {$IFDEF Store16bits} {Copy extra pixel values} PByte(Extra)^ := FOwner.GammaTable[pByte(LongInt(Src) + 5)^]; inc(Extra); PByte(Extra)^ := FOwner.GammaTable[pByte(LongInt(Src) + 3)^]; inc(Extra); PByte(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}: pByte); 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}: pByte); var I: Integer; begin FOR I := 1 TO ImageWidth DO begin {Copy alpha value and then gray value} {$IFDEF Store16bits} Extra^ := pByte(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: IStream; var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal); var j: Cardinal; Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pByte; CopyProc: procedure( Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte) 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.FImageData) + Header.BytesPerRow * (ImageHeight - 1); Trans := Header.FImageAlpha; {$IFDEF Store16bits} LongInt(Extra) := LongInt(Header.FExtraImageData) + 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: IStream; 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.FHasPalette 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], SizeOf(ChunkName)); {$ENDIF} Owner.GetPixelInfo(Row_Bytes, Offset); {Obtain line information} ZLIBStream := ZLIBInitInflate(Stream); {Initializes decompression} {Calculate ending position for the current IDAT chunk} EndPos := GMIStreamPos(Stream) + 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} GMSafeIStreamRead(Stream, @CRCCheck, SizeOf(CRCCheck)); {$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 AnsiChar = ('I', 'D', 'A', 'T'); BUFFER = 5; {Saves the IDAT chunk to a stream} function TChunkIDAT.SaveToStream(Stream: IStream): 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: IStream; Data: Pointer; const Length: Cardinal); var ChunkLen, CRC: Cardinal; begin {Writes IDAT header} ChunkLen := ByteSwap(Length); GMSafeIStreamWrite(Stream, @ChunkLen, SizeOf(ChunkLen)); {Chunk length} GMSafeIStreamWrite(Stream, @IDATHeader[0], SizeOf(IDATHeader)); {Idat header} CRC := update_crc($ffffffff, @IDATHeader[0], SizeOf(IDATHeader)); {Crc part for header} {Writes IDAT data and calculates CRC for data} GMSafeIStreamWrite(Stream, Data, Length); CRC := Byteswap(update_crc(CRC, Data, Length) xor $ffffffff); {Writes final CRC} GMSafeIStreamWrite(Stream, @CRC, SizeOf(CRC)); 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: pByte); var I: Integer; begin FOR I := 1 TO ImageWidth DO begin {Copy pixel values} PByte(Dest)^ := FOwner.FInverseGamma[pByte(LongInt(Src) + 2)^]; inc(Dest); PByte(Dest)^ := FOwner.FInverseGamma[pByte(LongInt(Src) + 1)^]; inc(Dest); PByte(Dest)^ := FOwner.FInverseGamma[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: pByte); 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.FInverseGamma[pByte(LongInt(Src) + 2)^]; inc(Dest, 2); pWORD(Dest)^ := FOwner.FInverseGamma[pByte(LongInt(Src) + 1)^]; inc(Dest, 2); pWORD(Dest)^ := FOwner.FInverseGamma[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: pByte); 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: pByte); 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: pByte); var i: Integer; begin {Copy the data to the destination, including data from Trans pointer} FOR i := 1 TO ImageWidth do begin PByte(Dest)^ := Owner.FInverseGamma[PByte(LongInt(Src) + 2)^]; inc(Dest); PByte(Dest)^ := Owner.FInverseGamma[PByte(LongInt(Src) + 1)^]; inc(Dest); PByte(Dest)^ := Owner.FInverseGamma[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: pByte); 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.FInverseGamma[PByte(LongInt(Src) + 2)^]; inc(Dest, 2); pWord(Dest)^ := Owner.FInverseGamma[PByte(LongInt(Src) + 1)^]; inc(Dest, 2); pWord(Dest)^ := Owner.FInverseGamma[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: pByte); 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: pByte); 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: IStream; var ZLIBStream: TZStreamRec2); var {Current line} j: Cardinal; {Pointers to image data} Data, Trans: pByte; {Filter used for this line} Filter: Byte; {Method which will copy the data into the buffer} CopyProc: procedure(Src, Dest, Trans: pByte) 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.FImageData) + Header.BytesPerRow * (ImageHeight - 1); Trans := Header.FImageAlpha; {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: pByte); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; Src := pByte(LongInt(Src) + Col * 3); repeat {Copy this row} PByte(Dest)^ := FOwner.FInverseGamma[pByte(LongInt(Src) + 2)^]; inc(Dest); PByte(Dest)^ := FOwner.FInverseGamma[pByte(LongInt(Src) + 1)^]; inc(Dest); PByte(Dest)^ := FOwner.FInverseGamma[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: pByte); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; Src := pByte(LongInt(Src) + Col * 3); repeat {Copy this row} pWord(Dest)^ := Owner.FInverseGamma[pByte(LongInt(Src) + 2)^]; inc(Dest, 2); pWord(Dest)^ := Owner.FInverseGamma[pByte(LongInt(Src) + 1)^]; inc(Dest, 2); pWord(Dest)^ := Owner.FInverseGamma[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: pByte); 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: pByte; begin {Clean the line} fillchar(Dest^, Row_Bytes, #0); {Get first column and enter in loop} Col := ColumnStart[Pass]; with Header.FBitmapInfo.bmiHeader do repeat {Copy data} CurBit := StartBit[biBitCount]; repeat {Adjust pointer to pixel byte bounds} Src2 := pByte(LongInt(Src) + (biBitCount * Col) div 8); {Copy data} PByte(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: pByte); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; Src := pByte(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: pByte); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; Src := pByte(LongInt(Src) + Col * 3); Trans := pByte(LongInt(Trans) + Col); repeat {Copy this row} PByte(Dest)^ := Owner.FInverseGamma[pByte(LongInt(Src) + 2)^]; inc(Dest); PByte(Dest)^ := Owner.FInverseGamma[pByte(LongInt(Src) + 1)^]; inc(Dest); PByte(Dest)^ := Owner.FInverseGamma[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: pByte); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; Src := pByte(LongInt(Src) + Col * 3); Trans := pByte(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: pByte); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; Src := pByte(LongInt(Src) + Col); Trans := pByte(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: pByte); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; Src := pByte(LongInt(Src) + Col); Trans := pByte(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: IStream; var ZLIBStream: TZStreamRec2); var CurrentPass, Filter: Byte; PixelsThisRow: Integer; CurrentRow : Integer; Trans, Data: pByte; CopyProc: procedure(const Pass: Byte; Src, Dest, Trans: pByte) 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.FImageData) + Header.BytesPerRow * (ImageHeight - 1 - CurrentRow)); Trans := Ptr(LongInt(Header.FImageAlpha) + 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 TGMPngImage} {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 TPNGFilter(ii) in Owner.Filters then begin Run := 0; {Check if it's the only filter} if Owner.Filters = [TPNGFilter(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 TPNGFilter(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.FBitmapInfo.bmiColors[Index]; end; {Loads the palette chunk from a stream} function TChunkPLTE.LoadFromStream(Stream: IStream; 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: IStream): Boolean; var J: Integer; DataPtr: pByte; FBitmapInfo: TMAXBITMAPINFO; palEntries: TMaxLogPalette; begin {Adjust size to hold all the palette items} if FCount = 0 then FCount := Header.FBitmapInfo.bmiHeader.biClrUsed; ResizeData(FCount * 3); {Get all the palette entries} fillchar(palEntries, sizeof(palEntries), #0); GetPaletteEntries(Header.FImagePalette, 0, 256, palEntries.palPalEntry[0]); {Copy pointer to data} DataPtr := FData; {Copy palette items} FBitmapInfo := Header.FBitmapInfo; FOR j := 0 TO FCount - 1 DO with palEntries.palPalEntry[j] do begin DataPtr^ := Owner.FInverseGamma[peRed]; inc(DataPtr); DataPtr^ := Owner.FInverseGamma[peGreen]; inc(DataPtr); DataPtr^ := Owner.FInverseGamma[peBlue]; inc(DataPtr); end {with FBitmapInfo}; {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: TGMPngImage); 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: IStream; 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); FInverseGamma[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; {TGMPngImage implementation} {Assigns from another object} procedure TGMPngImage.Assign(Source: TPersistent); begin {Being cleared} if Source = nil then ClearChunks {Assigns contents from another TGMPngImage} else if Source is TGMPngImage then AssignPNG(Source as TGMPngImage) {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 TGMPngImage.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 TObject(Chunks.Item[i]).Free; Chunks.Count := 0; end; constructor TGMPngImage.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); {$IFDEF UseDelphi}FCanvas := TCanvas.Create;{$ENDIF} FFilters := [pfSub]; FCompressionLevel := 7; FInterlaceMethod := imNone; FMaxIdatSize := High(Word); {Create chunklist object} FChunkList := TChunkList.Create(Self); end; {Portable Network Graphics object being created as a blank image} constructor TGMPngImage.CreateBlank(ColorType, BitDepth: Cardinal; cx, cy: Integer; const ARefLifeTime: Boolean = True); var NewIHDR: TChunkIHDR; begin {Calls creator} Create(ARefLifeTime); {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, EInvalidSpecText); Exit; end; if Bitdepth = 2 then Bitdepth := 4; {Add the basis chunks} InitializeGamma; FBeingCreated := True; Chunks.AddByClass(TChunkIEND); NewIHDR := Chunks.AddByClass(TChunkIHDR) as TChunkIHDR; NewIHDR.FIHDRData.ColorType := ColorType; NewIHDR.FIHDRData.BitDepth := BitDepth; NewIHDR.FIHDRData.Width := cx; NewIHDR.FIHDRData.Height := cy; NewIHDR.PrepareImageData; if NewIHDR.FHasPalette then TChunkPLTE(Chunks.AddByClass(TChunkPLTE)).FCount := 1 shl BitDepth; Chunks.AddByClass(TChunkIDAT); FBeingCreated := False; end; destructor TGMPngImage.Destroy; begin {Free object list} ClearChunks; FChunkList.Free; {$IFDEF UseDelphi}if FCanvas <> nil then FCanvas.Free;{$ENDIF} inherited Destroy; end; function TGMPngImage.Obj: TGMPngImage; begin Result := Self; end; {Returns linesize and byte offset for pixels} procedure TGMPngImage.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 TGMPngImage.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 TGMPngImage.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; function TGMPngImage.Size: TPoint; begin Result := GMPoint(Width, Height); end; {Returns if the image is empty} function TGMPngImage.GetEmpty: Boolean; begin Result := (Chunks.Count = 0); end; {Raises an error} procedure TGMPngImage.RaiseError(ExceptionClass: ExceptClass; Text: String); begin raise ExceptionClass.Create(Text); end; {Set the maximum size for IDAT chunk} procedure TGMPngImage.SetMaxIdatSize(const Value: LongWord); 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 TGMPngImage.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; { // Creates a file stream reading from the filename in the parameter and load procedure TGMPngImage.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 TGMPngImage.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; } {Returns if it has the pixel information chunk} function TGMPngImage.HasPixelInformation: Boolean; begin Result := (Chunks.ItemFromClass(TChunkpHYs) as tChunkpHYs) <> nil; end; {Returns the pixel information chunk} function TGMPngImage.GetPixelInformation: TChunkpHYs; begin Result := Chunks.ItemFromClass(TChunkpHYs) as tChunkpHYs; if not Assigned(Result) then begin Result := Chunks.AddByClass(tChunkpHYs) as tChunkpHYs; Result.FUnit := utMeter; end; end; {Returns pointer to the chunk TChunkIHDR which should be the first} function TGMPngImage.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 TGMPngImage.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} FBitmapInfo : 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; FImageData : 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(FBitmapInfo, sizeof(FBitmapInfo), #0); BitmapInfoHeader.biWidth := W; BitmapInfoHeader.biHeight := -Integer(H); FBitmapInfo.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, FBitmapInfo, 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); BytesPerRowAlpha := Header.Width; BytesPerRowDest := (((FBitmapInfo.bmiHeader.biBitCount * W) + 31) and not 31) div 8; // <- Number of bytes for each image row in destination BytesPerRowSrc := (((Header.FBitmapInfo.bmiHeader.biBitCount * Header.Width) + 31) and not 31) div 8; // <- Number of bytes for each image row in source FImageData := BufferBits; AlphaSource := Header.FImageAlpha; LongInt(ImageSource) := LongInt(Header.FImageData) + Header.BytesPerRow * LongInt(Header.Height - 1); ImageSourceOrg := ImageSource; case Header.FBitmapInfo.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�t have transparency} if (AlphaSource[i2] <> 0) then if (AlphaSource[i2] = 255) then begin pRGBTriple(@FImageData[i])^ := pRGBTriple(@ImageSource[i2 * 3])^; FImageData[i].rgbReserved := 255; end else with FImageData[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; rgbReserved := not ((255 + (not rgbReserved) * (not AlphaSource[i2])) shr 8); end; end; {Move pointers} inc(LongInt(FImageData), BytesPerRowDest); if Stretch then j2 := trunc(j / FactorY) else j2 := j; LongInt(ImageSource) := LongInt(ImageSourceOrg) - BytesPerRowSrc * j2; LongInt(AlphaSource) := LongInt(Header.FImageAlpha) + 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 FImageData[i], Header.FBitmapInfo 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(FImageData) := LongInt(FImageData) + BytesPerRowDest; if Stretch then j2 := trunc(j / FactorY) else j2 := j; LongInt(ImageSource) := LongInt(ImageSourceOrg) - BytesPerRowSrc * j2; LongInt(AlphaSource) := LongInt(Header.FImageAlpha) + 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 FImageData[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.FBitmapInfo.bmiHeader.biBitCount); until CurBit >= 8; {Move to next source data} //inc(Data); until i >= Integer(W); {Move pointers} LongInt(FImageData) := LongInt(FImageData) + BytesPerRowDest; if Stretch then j2 := trunc(j / FactorY) else j2 := j; LongInt(ImageSource) := LongInt(ImageSourceOrg) - BytesPerRowSrc * j2; end end {Palette images} end {case Header.FBitmapInfo.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 TGMPngImage.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.FImageData, Header.FBitmapInfo.bmiHeader, pBitmapInfo(@Header.FBitmapInfo), 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.FImageData, pBitmapInfo(@Header.FBitmapInfo)^, DIB_RGB_COLORS, SRCCOPY) end end {case} end; {Characters for the header} const PngHeader: array[0..7] of AnsiChar = (#137, #80, #78, #71, #13, #10, #26, #10); {Loads the image from a stream of data} procedure TGMPngImage.LoadFromStream(Stream: IStream); var Header : array[0..7] of AnsiChar; HasIDAT : Boolean; {Chunks reading} ChunkCount : LongInt; ChunkLength: Cardinal; ChunkName : TChunkName; begin {Initialize before start loading chunks} ChunkCount := 0; ClearChunks(); {Reads the header} GMSafeIStreamRead(Stream, @Header[0], SizeOf(Header)); {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 GMIStreamRead(Stream, @ChunkLength, SizeOf(ChunkLength)) = 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} GMSafeIStreamRead(Stream, @Chunkname, SizeOf(Chunkname)); {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); GMHrCheckObj(Stream.Seek(ChunkLength + 4, STREAM_SEEK_CUR, nil), Self); Continue; end; {Tell it has an IDAT chunk} if ChunkName = 'IDAT' then HasIDAT := TRUE; {Creates object for this chunk} Chunks.SetItem(ChunkCount - 1, CreateChunkByClass(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 TGMPngImage.SetHeight(Value: Integer); begin Resize(Width, Value) end; {Changing width is not supported} procedure TGMPngImage.SetWidth(Value: Integer); begin Resize(Value, Height) end; {$IFDEF UseDelphi} {Saves to clipboard format (thanks to Antoine Pottern)} procedure TGMPngImage.SaveToClipboardGMFormat(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)); SaveToClipboardGMFormat(AFormat, AData, APalette); finally Free; end {try} end; {Loads data from clipboard} procedure TGMPngImage.LoadFromClipboardGMFormat(AFormat: Word; AData: THandle; APalette: HPalette); begin with TBitmap.Create do try LoadFromClipboardGMFormat(AFormat, AData, APalette); Self.AssignHandle(Handle, False, 0); finally Free; end {try} end; {Returns if the image is transparent} function TGMPngImage.GetTransparent: Boolean; begin Result := (TransparencyMode <> ptmNone); end; {$ENDIF} {Saving the PNG image to a stream of data} procedure TGMPngImage.SaveToStream(Stream: IStream); var j: Integer; begin {Reads the header} GMSafeIStreamWrite(Stream, @PNGHeader[0], SizeOf(PNGHeader)); {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.FImageData, pBitmapInfo(@Header.FBitmapInfo)^, DIB_RGB_COLORS); DeleteDC(DC); end; {Assigns this TGMPngImage to another object} procedure TGMPngImage.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; BitmapData: PCardinal; PngData: PRGBTriple; AlphaData: PByte; I, J: Integer; {$ENDIF} begin {If the destination is also a TGMPngImage make it assign} {this one} if Dest is TGMPngImage then TGMPngImage(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)} else if (TransparencyMode = ptmPartial) then begin TBitmap(Dest).PixelFormat := pf32bit; TBitmap(Dest).AlphaFormat := afIgnored; TBitmap(Dest).Canvas.Draw(0, 0, Self); for I := 0 to Height - 1 do begin BitmapData := TBitmap(Dest).ScanLine[I]; PngData := Scanline[I]; AlphaData := PByte(AlphaScanline[I]); for J := 0 to Width - 1 do begin if not Header.FHasPalette then begin BitmapData^ := (AlphaData^ shl 24) or (Round(PngData^.rgbtRed) shl 16) or (Round(PngData^.rgbtGreen) shl 8) or (Round(PngData^.rgbtBlue)); BitmapData := PCardinal(Cardinal(BitmapData) + 4); PngData := PRGBTriple(Cardinal(PngData) + 3); AlphaData := PByte(Cardinal(AlphaData) + 1); end else begin BitmapData^ := (BitmapData^ and $00FFFFFF) or (AlphaData^ shl 24); BitmapData := PCardinal(Cardinal(BitmapData) + 4); AlphaData := PByte(Cardinal(AlphaData) + 1); end; end; end; TBitmap(Dest).AlphaFormat := afDefined; end; end else {Unknown destination kind} inherited AssignTo(Dest); {$ENDIF} end; {Assigns from a bitmap object} procedure TGMPngImage.AssignHandle(Handle: HBitmap; Transparent: Boolean; TransparentColor: ColorRef); var FBitmapInfo: Windows.TBitmap; {Chunks} Header: TChunkIHDR; PLTE: TChunkPLTE; IDAT: TChunkIDAT; IEND: TChunkIEND; TRNS: TChunkTRNS; i: Integer; palEntries : TMaxLogPalette; begin {Obtain bitmap info} GetObject(Handle, SizeOf(FBitmapInfo), @FBitmapInfo); {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, @FBitmapInfo); if Header.FHasPalette 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} Chunks.Add(Header); if Header.FHasPalette then Chunks.Add(PLTE); if Transparent then Chunks.Add(TRNS); Chunks.Add(IDAT); 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.FHasPalette then begin PLTE.FCount := 1 shl FBitmapInfo.bmBitsPixel; {Create and set palette} fillchar(palEntries, sizeof(palEntries), 0); palEntries.palVersion := $300; palEntries.palNumEntries := 1 shl FBitmapInfo.bmBitsPixel; for i := 0 to palEntries.palNumEntries - 1 do begin palEntries.palPalEntry[i].peRed := Header.FBitmapInfo.bmiColors[i].rgbRed; palEntries.palPalEntry[i].peGreen := Header.FBitmapInfo.bmiColors[i].rgbGreen; palEntries.palPalEntry[i].peBlue := Header.FBitmapInfo.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 TGMPngImage.AssignPNG(Source: TGMPngImage); 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} 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 TGMPngImage.GetAlphaScanline(const LineIndex: Integer): pByteArray; begin with Header do if (ColorType = COLOR_RGBALPHA) or (ColorType = COLOR_GRAYSCALEALPHA) then LongInt(Result) := LongInt(FImageAlpha) + (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 TGMPngImage.GetExtraScanline(const LineIndex: Integer): Pointer; begin with Header do LongInt(Result) := (LongInt(FExtraImageData) + ((LongInt(Height) - 1) * BytesPerRow)) - (LineIndex * BytesPerRow); end; {$ENDIF} {Returns a png data scanline} function TGMPngImage.GetScanline(const LineIndex: Integer): Pointer; begin with Header do PtrInt(Result) := (PtrInt(FImageData) + ((LongInt(Height) - 1) * BytesPerRow)) - (LineIndex * BytesPerRow); end; {function TGMPngImage.GetSupportsPartialTransparency: Boolean; begin Result := TransparencyMode = ptmPartial; end;} {Initialize gamma table} procedure TGMPngImage.InitializeGamma; var i: Integer; begin {Build gamma table as if there was no gamma} FOR i := 0 to 255 do begin GammaTable[i] := i; FInverseGamma[i] := i; end {for i} end; {Returns the transparency mode used by this png} function TGMPngImage.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 TGMPngImage.AddtEXt(const Keyword, Text: AnsiString); var TextChunk: TChunkTEXT; begin TextChunk := Chunks.AddByClass(TChunkText) as TChunkTEXT; TextChunk.Keyword := Keyword; TextChunk.Text := Text; end; {Add a text chunk} procedure TGMPngImage.AddzTXt(const Keyword, Text: AnsiString); var TextChunk: TChunkzTXt; begin TextChunk := Chunks.AddByClass(TChunkzTXt) as TChunkzTXt; TextChunk.Keyword := Keyword; TextChunk.Text := Text; end; {Removes the image transparency} procedure TGMPngImage.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 FImageAlpha <> nil then FreeMem(FImageAlpha); FImageAlpha := nil end end end; {Generates alpha information} procedure TGMPngImage.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(FImageAlpha, Integer(Width) * Integer(Height)); FillChar(FImageAlpha^, 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.AddByClass(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 TGMPngImage.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 TGMPngImage.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.AddByClass(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 TGMPngImage.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: TGMPngImage; 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: TGMPngImage; 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: TGMPngImage; 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: TGMPngImage; 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: TGMPngImage; 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: TGMPngImage; const X, Y: Integer; Value: TColor); begin PByteArray(png.Scanline[Y])^[X] := GetRValue(Value); end; {Resizes the PNG image} procedure TGMPngImage.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.FImageDC); Header.FBitmapInfo.bmiHeader.biWidth := cx; Header.FBitmapInfo.bmiHeader.biHeight := cy; NewHandle := CreateDIBSection(NewDC, pBitmapInfo(@Header.FBitmapInfo)^, DIB_RGB_COLORS, NewImageData, 0, 0); SelectObject(NewDC, NewHandle); {$IFDEF UseDelphi}Canvas.Handle := NewDC;{$ENDIF} NewBytesPerRow := (((Header.FBitmapInfo.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.FImageAlpha); Header.FImageAlpha := 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.FExtraImageData); Header.FExtraImageData := NewImageExtra; end; {$ENDIF} {Deletes the old image} DeleteObject(Header.FImageHandle); DeleteDC(Header.FImageDC); {Prepares the header to get the new image} Header.BytesPerRow := NewBytesPerRow; Header.FIHDRData.Width := CX; Header.FIHDRData.Height := CY; Header.FImageData := NewImageData; {Replaces with the new image} Header.FImageHandle := NewHandle; Header.FImageDC := NewDC; end else {The new size provided is invalid} RaiseError(EPNGInvalidNewSize, EInvalidNewSizeText) end; {Sets a pixel} procedure TGMPngImage.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 TGMPngImage.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 TGMPngImage.GetPalette: HPALETTE; begin Result := Header.FImagePalette; 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: IStream; 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: IStream): 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 TGMPngImage.DoSetPalette(Value: HPALETTE; const UpdateColors: boolean); begin if (Header.FHasPalette) then begin {Update the palette entries} if UpdateColors then Header.PaletteToDIB(Value); {Resize the new palette} SelectPalette(Header.FImageDC, Value, False); RealizePalette(Header.FImageDC); {Replaces} DeleteObject(Header.FImagePalette); Header.FImagePalette := Value; end end; {Set palette based on a windows palette handle} procedure TGMPngImage.SetPalette(Value: HPALETTE); begin DoSetPalette(Value, true); end; {Returns the library version} //function TGMPngImage.GetLibraryVersion: String; //begin //Result := LibraryVersion //end; initialization {crc table has not being computed yet} crc_table_computed := FALSE; {$IFDEF UseDelphi}{$IFDEF RegisterGraphic} TPicture.RegisterFileGMFormat('PNG', 'Portable Network Graphics', TGMPngImage); {$ENDIF}{$ENDIF} finalization {$IFDEF UseDelphi}{$IFDEF RegisterGraphic} TPicture.UnregisterGraphicClass(TGMPngImage); {$ENDIF}{$ENDIF} end.