VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "clsPNGInfo" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit ' PiNG info version 1.0 ' Written by Mike D Sutton of EDais ' ' E-Mail: EDais@mvps.org ' WWW: Http://www.mvps.org/EDais/ ' ' Written: 24/07/2004 ' Last edited: 24/07/2004 'Version history: '---------------- ' Version 1.0 (24/07/2004): ' Added FileName, FileSize, Width, Height, BitDepth, ChannelDepth, ColourType, Interlace, Palette[], ' PalSize, Gamma, SRGBRenderingIntent, PixelsPerUnitX, PixelsPerUnitY, UnitSpecifier, WhitePointX, ' WhitePointY, RedX, RedY, GreenX, GreenY, BlueX, BlueY, HasHeader, HasFooter, HassRGB, HasChroma, ' HasGamma, HasPalette, HasBackground, HasPhysicalDimensions, HasTransparency, HasSignificantBit, ' HasTime, Background, BackgroundRGB, DataPosition[], DataLength[], NumData, TextKeyword[], ' TextValue[], NumTexts, CheckCRC, CheckDataCRC, TransparentColour, NumSignificantBits, ' SignificantBits[] and TimeLastMod properties (!!) ' ' ReadFile() - Opens a .png file and parses the file structure, performing basic validation ' GetPalEntry() - Returns a palette entry, equivalent of the .Palette() property get ' PNGParseErrorToString() - Returns a string containing the description of an parse error code ' ReadPNGChunk() - [Private] Reads a chunk from an open .png file and populates a typPNGChunk strcuture ' GetChunkCRC() - [Private] Calculates the CRC for a chunk structure ' IsValidChunk() - [Private] Simple validation of chunk properties ' IsValidChunkCRC() - [Private] Performs validation of chunk CRC (where required) ' InterpretChunk() - [Private] Attempts to perform interpretation of a chunk strcuture ' InterpretHeaderChunk() - [Private] Interprets and validates a header (IHDR) chunk ' InterpretPaletteChunk() - [Private] Interprets and validates a palette (PLTE) chunk ' InterpretChromaChunk() - [Private] Interprets and validates a chroma (cHRM) chunk ' InterpretSRGBChunk() - [Private] Interprets and validates an sRGB (sRGB) chunk ' InterpretTextChunk() - [Private] Interprets and validates a text (tEXt) chunk ' InterpretBackgroundChunk() - [Private] Interprets and validates a background (bKGD) chunk ' InterpretPhysicalDimsChunk() - [Private] Interprets and validates a physical dimensions (pHYs) chunk ' InterpretTransparencyChunk() - [Private] Interprets and validates a transparency (tRNS) chunk ' InterpretSignificantBit() - [Private] Interprets and validates a significant bits (sBIT) chunk ' IntrepretTimeChunk() - [Private] Interprets and validates a time (tIME) chunk ' TrimNull() - [Private] Trims the junk from the end of a null-terminated string ' Min() - [Private] Returns the minimum of two values ' MakeDWordFromArr() - [Private] Creates a DWord from part of a byte array ' MakeDWord() - [Private] Creates a DWord from 4 bytes ' DWordToFourCC() - [Private] Converts a DWord to a four-character-code string ' FourCCToDWord() - [Private] Converts a four-character-code string to a DWord ' FlipDWord() - [Private] Flips the byte ordering of a DWord ' ClearInfo() - [Private] Clears all the internal data ' FileExist() - [Private] Checks to see whether a file exists ' MakeCRCTable() - [Private] Creates the CRC lookup table ' UpdateCRC() - [Private] Calcualtes the CRC for a data block '--------------------------------' Private Type typPNGChunk pcLength As Long pcType As Long pcData() As Byte psCRC As Long End Type Private Type typPNGTextChunk ptcKeyword As String ptcText As String End Type Private Type typPNGDataChunk pdcPosition As Long pdcLength As Long End Type Public Enum enPNGColourType pctGreyscale = &H0 pctRGB = &H2 pctPalette = &H3 pctGreyscaleWithAlpha = &H4 pctRGBWithAlpha = &H6 End Enum Public Enum enPNGInterlace piNone = &H0 piAdam7 = &H1 End Enum Public Enum enPNGSRGBRenderingIntent psriPerceptual = &H0 psriRelativeColourimetric = &H1 psriSaturation = &H2 psriAbsoluteColourimetric = &H3 End Enum Public Enum enPNGUnitSpecifier pusUnknown = &H0 pusMeter = &H1 End Enum Public Enum enPNGChunkPresent pcpNo = &H0 pcpYes = &H1 pcpInterpreted = &H2 End Enum Public Enum enPNGCRCResult pcrcrFailed = &H0 pcrcrSucceeded = &H1 pcrcrSkipped = &H2 End Enum Public Enum enPNGChunkInterpretation pciFailed = &H0 pciSucceeded = &H1 pciUnsupported = &H2 End Enum Public Enum enPNGParseError ppeNoError = &H0 ' File errors ppeFileNotFound = &H1 ppeFileSignatureIncorrect = &H2 ' Generic chunk error ppeErrorReadingChunk = &H3 ppeInvalidChunk = &H4 ppeChunkCRCIncorrect = &H5 ppeChunkInterpretationFailed = &H6 ppeInvalidChunkSize = &H7 ppeUnexpectedChunkSize = &H8 ppeDuplicateChunkType = &H9 ' Missing critical chunks ppeMissingHeaderChunk = &H80 ppeMissingFooterChunk = &H81 ppeMissingDataChunk = &H82 ppeMissingPaletteChunk = &H83 ' Header errors ppeInvalidColourTypeAndDepthCombination = &H103 ppeInvalidImageDimension = &H104 ppeInvalidCompressionMethod = &H105 ppeInvalidFilterMethod = &H106 ppeInvalidInterlaceMethod = &H107 ' Palette errors ppeUnexpectedPalette = &H108 ppeInvalidPaletteSize = &H109 ppeInvalidPaletteColourCount = &H10A End Enum Private Const PNGChunkIHDR As Long = &H52444849 ' IHDR Private Const PNGChunkPLTE As Long = &H45544C50 ' PLTE Private Const PNGChunkgAMA As Long = &H414D4167 ' gAMA Private Const PNGChunkcHRM As Long = &H4D524863 ' cHRM Private Const PNGChunksRGB As Long = &H42475273 ' sRGB Private Const PNGChunktEXt As Long = &H74584574 ' tEXt Private Const PNGChunkbKGD As Long = &H44474B62 ' bKGD Private Const PNGChunkpHYs As Long = &H73594870 ' pHYs Private Const PNGChunkIEND As Long = &H444E4549 ' IEND Private Const PNGChunkIDAT As Long = &H54414449 ' IDAT Private Const PNGChunktIME As Long = &H454D4974 ' tIME Private Const PNGChunktRNS As Long = &H534E5274 ' tRNS Private Const PNGChunksBIT As Long = &H54494273 ' sBIT 'Private Const PNGChunkzTXt As Long = &H7458547A ' zTXt Private Const GammaMultiplier As Long = 100000 Private Const ChromaMultiplier As Long = 100000 Private m_FileName As String Private m_FileSize As Long Private m_Width As Long Private m_Height As Long Private m_ChannelDepth As Byte Private m_ColourType As enPNGColourType Private m_Interlace As enPNGInterlace Private m_Palette() As Long Private m_PalSize As Long Private m_Gamma As Double Private m_SRGBRenderingIntent As enPNGSRGBRenderingIntent Private m_Background As Long Private m_PixelsPerUnitX As Long Private m_PixelsPerUnitY As Long Private m_UnitSpecifier As enPNGUnitSpecifier Private m_TransparentColour As Long Private m_HasHeader As enPNGChunkPresent Private m_HasFooter As enPNGChunkPresent Private m_HassRGB As enPNGChunkPresent Private m_HasChroma As enPNGChunkPresent Private m_HasGamma As enPNGChunkPresent Private m_HasPalette As enPNGChunkPresent Private m_HasBackground As enPNGChunkPresent Private m_HasPhysicaDims As enPNGChunkPresent Private m_HasTransparency As enPNGChunkPresent Private m_HasSignificantBit As enPNGChunkPresent Private m_HasTime As enPNGChunkPresent Private m_WhitePointX As Double Private m_WhitePointY As Double Private m_RedX As Double Private m_RedY As Double Private m_GreenX As Double Private m_GreenY As Double Private m_BlueX As Double Private m_BlueY As Double Private m_Data() As typPNGDataChunk Private m_NumDatas As Long Private m_Text() As typPNGTextChunk Private m_NumTexts As Long Private m_CheckCRC As Boolean Private m_CheckDataCRC As Boolean Private m_TimeLastMod As Date Dim m_SBits(3) As Byte Dim m_NumSBit As Long Private CRCTable(255) As Long Private GotCRCTable As Boolean Public Event ParseError(ByVal inError As enPNGParseError) Public Event FoundChunk(ByRef inType As String, ByVal inPosition As Long, ByVal inSize As Long, _ ByVal inChunkInterpretation As enPNGChunkInterpretation, ByVal inCRCCheck As enPNGCRCResult) Public Property Get FileName() As String FileName = m_FileName End Property Public Property Get FileSize() As Long FileSize = m_FileSize End Property Public Property Get Width() As Long Width = m_Width End Property Public Property Get Height() As Long Height = m_Height End Property Public Property Get BitDepth() As Byte Select Case m_ColourType Case pctGreyscale, pctPalette: BitDepth = m_ChannelDepth Case pctGreyscaleWithAlpha: BitDepth = m_ChannelDepth * 2 Case pctRGB: BitDepth = m_ChannelDepth * 3 Case pctRGBWithAlpha: BitDepth = m_ChannelDepth * 4 End Select End Property Public Property Get ChannelDepth() As Byte ChannelDepth = m_ChannelDepth End Property Public Property Get ColourType() As enPNGColourType ColourType = m_ColourType End Property Public Property Get Interlace() As enPNGInterlace Interlace = m_Interlace End Property Public Property Get Palette(ByVal inIdx As Long) As Long If ((inIdx <= 0) Or inIdx > m_PalSize) Then Exit Property Palette = m_Palette(inIdx - 1) End Property Public Property Get PalSize() As Long PalSize = m_PalSize End Property Public Property Get Gamma() As Double Gamma = m_Gamma End Property Public Property Get SRGBRenderingIntent() As enPNGSRGBRenderingIntent SRGBRenderingIntent = m_SRGBRenderingIntent End Property Public Property Get PixelsPerUnitX() As Long PixelsPerUnitX = m_PixelsPerUnitX End Property Public Property Get PixelsPerUnitY() As Long PixelsPerUnitY = m_PixelsPerUnitY End Property Public Property Get UnitSpecifier() As enPNGUnitSpecifier UnitSpecifier = m_UnitSpecifier End Property Public Property Get WhitePointX() As Double WhitePointX = m_WhitePointX End Property Public Property Get WhitePointY() As Double WhitePointY = m_WhitePointY End Property Public Property Get RedX() As Double RedX = m_RedX End Property Public Property Get RedY() As Double RedY = m_RedY End Property Public Property Get GreenX() As Double GreenX = m_GreenX End Property Public Property Get GreenY() As Double GreenY = m_GreenY End Property Public Property Get BlueX() As Double BlueX = m_BlueX End Property Public Property Get BlueY() As Double BlueY = m_BlueY End Property Public Property Get HasHeader() As enPNGChunkPresent HasHeader = m_HasHeader End Property Public Property Get HasFooter() As enPNGChunkPresent HasFooter = m_HasFooter End Property Public Property Get HassRGB() As enPNGChunkPresent HassRGB = m_HassRGB End Property Public Property Get HasChroma() As enPNGChunkPresent HasChroma = m_HasChroma End Property Public Property Get HasGamma() As enPNGChunkPresent HasGamma = m_HasGamma End Property Public Property Get HasPalette() As enPNGChunkPresent HasPalette = m_HasPalette End Property Public Property Get HasBackground() As enPNGChunkPresent HasBackground = m_HasBackground End Property Public Property Get HasPhysicalDimensions() As enPNGChunkPresent HasPhysicalDimensions = m_HasPhysicaDims End Property Public Property Get HasTransparency() As enPNGChunkPresent HasTransparency = m_HasTransparency End Property Public Property Get HasSignificantBit() As enPNGChunkPresent HasSignificantBit = m_HasSignificantBit End Property Public Property Get HasTime() As enPNGChunkPresent HasTime = m_HasTime End Property Public Property Get Background() As Long Background = m_Background End Property Public Property Get BackgroundRGB() As Long Select Case m_ColourType Case pctGreyscale, pctGreyscaleWithAlpha: BackgroundRGB = (m_Background And &HFF) * &H10101 Case pctRGB, pctRGBWithAlpha: BackgroundRGB = m_Background Case pctPalette: BackgroundRGB = Me.Palette(m_Background) End Select End Property Public Property Get DataPosition(ByVal inIdx As Long) As Long If ((inIdx < 0) Or (inIdx >= m_NumDatas)) Then Exit Property DataPosition = m_Data(inIdx).pdcPosition End Property Public Property Get DataLength(ByVal inIdx As Long) As Long If ((inIdx < 0) Or (inIdx >= m_NumDatas)) Then Exit Property DataLength = m_Data(inIdx).pdcLength End Property Public Property Get NumData() As Long NumData = m_NumDatas End Property Public Property Get TextKeyword(ByVal inIdx As Long) As String If ((inIdx < 0) Or (inIdx >= m_NumTexts)) Then Exit Property TextKeyword = m_Text(inIdx).ptcKeyword End Property Public Property Get TextValue(ByVal inIdx As Long) As String If ((inIdx < 0) Or (inIdx >= m_NumTexts)) Then Exit Property TextValue = m_Text(inIdx).ptcText End Property Public Property Get NumTexts() As Long NumTexts = m_NumTexts End Property Public Property Get CheckCRC() As Boolean CheckCRC = m_CheckCRC End Property Public Property Let CheckCRC(ByVal inNew As Boolean) m_CheckCRC = inNew m_CheckDataCRC = m_CheckDataCRC And m_CheckCRC If (inNew) Then Call MakeCRCTable End Property Public Property Get CheckDataCRC() As Boolean CheckDataCRC = m_CheckDataCRC End Property Public Property Let CheckDataCRC(ByVal inNew As Boolean) m_CheckDataCRC = inNew And m_CheckCRC End Property Public Property Get TransparentColour() As Long TransparentColour = m_TransparentColour End Property Public Property Get NumSignificantBits() As Long NumSignificantBits = m_NumSBit End Property Public Property Get SignificantBits(ByVal inIdx As Long) As Byte If ((inIdx >= 0) And (inIdx < m_NumSBit)) Then SignificantBits = m_SBits(inIdx) End Property Public Property Get TimeLastMod() As Date TimeLastMod = m_TimeLastMod End Property Public Function ReadFile(ByRef inFile As String) As Boolean Dim PingSig(1) As Long Dim FNum As Integer Dim PNGChunk As typPNGChunk Dim ChunkPos As Long Dim ChunkCRCRes As enPNGCRCResult Dim ChunkInterpretRes As enPNGChunkInterpretation Dim ValidChunk As Boolean ' Clean any existing member data Call ClearInfo ' Check that the input file exists If (Not FileExist(inFile)) Then RaiseEvent ParseError(ppeFileNotFound) Exit Function End If FNum = FreeFile() ' Grab a free file handle and open the file Open inFile For Binary Access Read Lock Write As #FNum Get #FNum, , PingSig() ' Read in the first 8 bytes ' Validate PiNG format signature If (Not ((PingSig(0) = &H474E5089) And (PingSig(1) = &HA1A0A0D))) Then Close #FNum RaiseEvent ParseError(ppeFileSignatureIncorrect) Exit Function End If ' Set file name and size member variables m_FileName = inFile m_FileSize = LOF(FNum) Do ' Step through image chunks ChunkPos = Seek(FNum) - 1 ' Read PNG chunk from file, and if valid, process PNGChunk = ReadPNGChunk(FNum) If (PNGChunk.pcType = 0) Then RaiseEvent ParseError(ppeErrorReadingChunk) Exit Do ' Invalid chunk type, most likely invalid file - quit End If ValidChunk = IsValidChunk(PNGChunk, ChunkCRCRes) ChunkInterpretRes = pciFailed If (ValidChunk) Then ChunkInterpretRes = InterpretChunk(PNGChunk, ChunkPos) 'If (ChunkInterpretRes = pciFailed) Then RaiseEvent ParseError(ppeChunkInterpretationFailed) Else RaiseEvent ParseError(IIf(ChunkCRCRes = pcrcrFailed, ppeChunkCRCIncorrect, ppeInvalidChunk)) End If RaiseEvent FoundChunk(DWordToFourCC(PNGChunk.pcType), ChunkPos, _ PNGChunk.pcLength, ChunkInterpretRes, ChunkCRCRes) If (PNGChunk.pcType = PNGChunkIEND) Then m_HasFooter = pcpYes ' The "IEND" signifies the end of the file and we should Exit Do ' stop parsing regardless of any additional data (Undefined) End If Loop While ValidChunk And Not EOF(FNum) ' As long as the image has a header, footer and data then we assume that it's valid ReadFile = (m_HasHeader = pcpYes) And (m_HasFooter = pcpYes) And (m_NumDatas > 0) If (Not ReadFile) Then If (m_HasHeader <> pcpYes) Then RaiseEvent ParseError(ppeMissingHeaderChunk) If (m_HasFooter <> pcpYes) Then RaiseEvent ParseError(ppeMissingFooterChunk) If (m_NumDatas < 1) Then RaiseEvent ParseError(ppeMissingDataChunk) End If ' Paletted images must have a pallete chunk If (m_ColourType = pctPalette) Then ReadFile = ReadFile And (m_HasPalette = pcpYes) If (Not ReadFile) Then RaiseEvent ParseError(ppeMissingPaletteChunk) End If Close #FNum End Function Public Function GetPalEntry(ByVal inIdx As Byte) As Long GetPalEntry = Me.Palette(CLng(inIdx)) End Function Public Function PNGParseErrorToString(ByVal inError As enPNGParseError) As String Select Case inError Case ppeNoError: PNGParseErrorToString = "No error" ' File errors Case ppeFileNotFound: PNGParseErrorToString = "File not found" Case ppeFileSignatureIncorrect: PNGParseErrorToString = "PNG signature incorrect" ' Generic chunk error Case ppeErrorReadingChunk: PNGParseErrorToString = "Error reading chunk" Case ppeInvalidChunk: PNGParseErrorToString = "Invalid chunk" Case ppeChunkCRCIncorrect: PNGParseErrorToString = "Chunk CRC check failed" Case ppeChunkInterpretationFailed: PNGParseErrorToString = "Chunk intepretation failed" Case ppeInvalidChunkSize: PNGParseErrorToString = "Invalid chunk size" Case ppeUnexpectedChunkSize: PNGParseErrorToString = "Unexpected chunk size" Case ppeDuplicateChunkType: PNGParseErrorToString = "Duplicate chunk type (only one allowed)" ' Missing critical chunks Case ppeMissingHeaderChunk: PNGParseErrorToString = "Critical header chunk missing" Case ppeMissingFooterChunk: PNGParseErrorToString = "Critical footer chunk missing" Case ppeMissingDataChunk: PNGParseErrorToString = "Critical data chunk missing" Case ppeMissingPaletteChunk: PNGParseErrorToString = "Critical palette chunk missing" ' Header errors Case ppeInvalidColourTypeAndDepthCombination: PNGParseErrorToString = "Invalid colour type and depth combination" Case ppeInvalidImageDimension: PNGParseErrorToString = "Invalid inamge dimension" Case ppeInvalidCompressionMethod: PNGParseErrorToString = "Invalid compression method" Case ppeInvalidFilterMethod: PNGParseErrorToString = "Invalid filter method" Case ppeInvalidInterlaceMethod: PNGParseErrorToString = "Invalid interlace menthod" ' Palette errors Case ppeUnexpectedPalette: PNGParseErrorToString = "Palette unexpected at this bit-depth" Case ppeInvalidPaletteSize: PNGParseErrorToString = "Invalid palette size" Case ppeInvalidPaletteColourCount: PNGParseErrorToString = "Invalid palette colour count" Case Else: PNGParseErrorToString = "Unknown error value (" & inError & ")" End Select End Function Private Function ReadPNGChunk(ByVal inFile As Integer) As typPNGChunk Get #inFile, , ReadPNGChunk.pcLength Get #inFile, , ReadPNGChunk.pcType If (ReadPNGChunk.pcLength And &H80) Then ' Too large for a PiNG chunk RaiseEvent ParseError(ppeInvalidChunkSize) ReadPNGChunk.pcLength = 0 ReadPNGChunk.pcType = 0 Exit Function End If ' Flip byte ordering for length field ReadPNGChunk.pcLength = FlipDWord(ReadPNGChunk.pcLength) If (ReadPNGChunk.pcLength > 0) Then ' Read any chunk data ReDim ReadPNGChunk.pcData(ReadPNGChunk.pcLength - 1) As Byte Get #inFile, , ReadPNGChunk.pcData() End If ' Read Cyclic Redundancy Check field and reverse byte order Get #inFile, , ReadPNGChunk.psCRC ReadPNGChunk.psCRC = FlipDWord(ReadPNGChunk.psCRC) End Function Private Function GetChunkCRC(ByRef inChunk As typPNGChunk) As Long Dim TypeBuf(3) As Byte ' Convert type field to individual bytes TypeBuf(0) = inChunk.pcType And &HFF& TypeBuf(1) = (inChunk.pcType And &HFF00&) \ &H100& TypeBuf(2) = (inChunk.pcType And &HFF0000) \ &H10000 TypeBuf(3) = ((inChunk.pcType And &HFF000000) \ &H1000000) And &HFF& ' Calculate CRC on type then on any additional data buffer GetChunkCRC = UpdateCRC(&HFFFFFFFF, TypeBuf(), 4) If (inChunk.pcLength > 0) Then _ GetChunkCRC = UpdateCRC(GetChunkCRC, inChunk.pcData(), inChunk.pcLength) GetChunkCRC = Not GetChunkCRC ' Return 1's compliment of combined CRC End Function Private Function IsValidChunk(ByRef inChunk As typPNGChunk, _ ByRef outCRCResult As enPNGCRCResult) As Boolean IsValidChunk = inChunk.pcLength >= 0 ' Validate chunk length If (IsValidChunk) Then ' Perform CRC check outCRCResult = IsValidChunkCRC(inChunk) IsValidChunk = outCRCResult <> pcrcrFailed End If End Function Private Function IsValidChunkCRC(ByRef inChunk As typPNGChunk) As enPNGCRCResult If (Not m_CheckCRC) Then ' No CRC required for any chunks IsValidChunkCRC = pcrcrSkipped Else If ((inChunk.pcType = PNGChunkIDAT) And (Not m_CheckDataCRC)) Then IsValidChunkCRC = pcrcrSkipped ' CRC not required for data chunks Else If (GetChunkCRC(inChunk) = inChunk.psCRC) Then IsValidChunkCRC = pcrcrSucceeded Else IsValidChunkCRC = pcrcrFailed End If End If End If End Function Private Function InterpretChunk(ByRef inChunk As typPNGChunk, _ ByVal inPosition As Long) As enPNGChunkInterpretation Dim InterpretResult As Boolean, UnknownType As Boolean Select Case inChunk.pcType Case PNGChunkIHDR ' Image header InterpretResult = InterpretHeaderChunk(inChunk) Case PNGChunkPLTE ' Image palette InterpretResult = InterpretPaletteChunk(inChunk) Case PNGChunkgAMA ' Image gamma InterpretResult = inChunk.pcLength = 4 If (InterpretResult) Then m_HasGamma = pcpYes ' Interpret gamma in-line since there's so little to it m_Gamma = MakeDWordFromArr(inChunk.pcData(), 0, True) / GammaMultiplier Else RaiseEvent ParseError(ppeUnexpectedChunkSize) End If Case PNGChunkcHRM ' Primary chromaticities InterpretResult = InterpretChromaChunk(inChunk) Case PNGChunksRGB ' Standard RGB colour space InterpretResult = InterpretSRGBChunk(inChunk) Case PNGChunktEXt ' Textual data InterpretResult = InterpretTextChunk(inChunk) Case PNGChunkbKGD ' Background colour InterpretResult = InterpretBackgroundChunk(inChunk) Case PNGChunkpHYs ' Physical pixel dimensions InterpretResult = InterpretPhysicalDimsChunk(inChunk) Case PNGChunkIDAT ' Image data ReDim Preserve m_Data(m_NumDatas) As typPNGDataChunk With m_Data(m_NumDatas) .pdcPosition = inPosition + 8 .pdcLength = inChunk.pcLength End With m_NumDatas = m_NumDatas + 1 InterpretResult = True Case PNGChunktIME ' Image last-modification time InterpretResult = IntrepretTimeChunk(inChunk) Case PNGChunktRNS ' Transparency InterpretResult = InterpretTransparencyChunk(inChunk) Case PNGChunksBIT ' Significant bits InterpretResult = InterpretSignificantBit(inChunk) Case PNGChunkIEND ' Nothing to do InterpretResult = True Case Else ' Unknown chunk type! UnknownType = True End Select If (UnknownType) Then ' Don't know this chunk type InterpretChunk = pciUnsupported Else ' Return interpretation result InterpretChunk = IIf(InterpretResult, pciSucceeded, pciFailed) End If End Function Private Function InterpretHeaderChunk(ByRef inChunk As typPNGChunk) As Boolean If (m_HasHeader) Then RaiseEvent ParseError(ppeDuplicateChunkType) Exit Function ' Can't have two headers! End If ' Validate header chunk length (Always a fixed size) If (inChunk.pcLength <> 13) Then RaiseEvent ParseError(ppeUnexpectedChunkSize) Exit Function End If ' Set class properties m_Width = MakeDWordFromArr(inChunk.pcData, 0, True) m_Height = MakeDWordFromArr(inChunk.pcData, 4, True) m_ChannelDepth = inChunk.pcData(8) m_ColourType = inChunk.pcData(9) m_Interlace = inChunk.pcData(12) Select Case m_ColourType Case 0 ' Greyscale Select Case m_ChannelDepth Case 1, 2, 4, 8, 16: InterpretHeaderChunk = True End Select Case 2, 4, 6 ' RGB, Greyscale with alpha, RGB with alpha Select Case m_ChannelDepth Case 8, 16: InterpretHeaderChunk = True End Select Case 3 ' Palette Select Case m_ChannelDepth Case 1, 2, 4, 8: InterpretHeaderChunk = True End Select End Select ' If bit-depth and colour type validation succeeded, validate image size, compression ' (deflate/inflate compression with a sliding window of at most 32768 bytes), filter ' (adaptive filtering with five basic filter types) and interlace method. If (InterpretHeaderChunk) Then InterpretHeaderChunk = False If ((m_Width > 0) And (m_Height > 0)) Then If (inChunk.pcData(10) = 0) Then If (inChunk.pcData(11) = 0) Then If (m_Interlace <= 1) Then InterpretHeaderChunk = True m_HasHeader = pcpYes Else RaiseEvent ParseError(ppeInvalidInterlaceMethod) End If Else RaiseEvent ParseError(ppeInvalidFilterMethod) End If Else RaiseEvent ParseError(ppeInvalidCompressionMethod) End If Else RaiseEvent ParseError(ppeInvalidImageDimension) End If Else RaiseEvent ParseError(ppeInvalidColourTypeAndDepthCombination) End If End Function Private Function InterpretPaletteChunk(ByRef inChunk As typPNGChunk) As Boolean Dim LoopPal As Long, DataOff As Long If (m_HasPalette) Then RaiseEvent ParseError(ppeDuplicateChunkType) Exit Function ' Can't have more than one palette! End If Select Case m_ColourType Case pctPalette, pctRGB, pctRGBWithAlpha Case Else ' This chunk shouldn't appear in this image type! RaiseEvent ParseError(ppeUnexpectedPalette) Exit Function End Select m_PalSize = inChunk.pcLength \ 3 ' Validate palette size, must have between 1 and maximum number of ' colours available at this bit depth (2^depth) with no remaning bytes If ((inChunk.pcLength Mod 3) = 0) Then If (m_PalSize >= 1) And (m_PalSize <= (2 ^ m_ChannelDepth)) Then InterpretPaletteChunk = True Else RaiseEvent ParseError(ppeInvalidPaletteColourCount) End If Else RaiseEvent ParseError(ppeInvalidPaletteSize) End If If (InterpretPaletteChunk) Then m_HasPalette = pcpYes ReDim m_Palette(m_PalSize - 1) As Long For LoopPal = 0 To m_PalSize - 1 ' Read palette data m_Palette(LoopPal) = CLng(inChunk.pcData(DataOff)) Or _ (&H100& * inChunk.pcData(DataOff + 1)) Or _ (&H10000 * inChunk.pcData(DataOff + 2)) DataOff = DataOff + 3 Next LoopPal End If End Function Private Function InterpretChromaChunk(ByRef inChunk As typPNGChunk) As Boolean ' Validate chunk size If (inChunk.pcLength < 32) Then RaiseEvent ParseError(ppeUnexpectedChunkSize) Exit Function End If m_WhitePointX = MakeDWordFromArr(inChunk.pcData(), 0, True) / ChromaMultiplier m_WhitePointY = MakeDWordFromArr(inChunk.pcData(), 4, True) / ChromaMultiplier m_RedX = MakeDWordFromArr(inChunk.pcData(), 8, True) / ChromaMultiplier m_RedY = MakeDWordFromArr(inChunk.pcData(), 12, True) / ChromaMultiplier m_GreenX = MakeDWordFromArr(inChunk.pcData(), 16, True) / ChromaMultiplier m_GreenY = MakeDWordFromArr(inChunk.pcData(), 20, True) / ChromaMultiplier m_BlueX = MakeDWordFromArr(inChunk.pcData(), 24, True) / ChromaMultiplier m_BlueY = MakeDWordFromArr(inChunk.pcData(), 28, True) / ChromaMultiplier ' No validation to perform InterpretChromaChunk = True m_HasChroma = pcpYes End Function Private Function InterpretSRGBChunk(ByRef inChunk As typPNGChunk) As Boolean If (inChunk.pcLength < 1) Then RaiseEvent ParseError(ppeUnexpectedChunkSize) Exit Function End If If (inChunk.pcData(0) < 4) Then m_HassRGB = pcpYes m_SRGBRenderingIntent = inChunk.pcData(0) End If If (m_HasGamma = pcpNo) Then m_HasGamma = pcpInterpreted ' Set default gamma values for sRGB m_Gamma = 45455 / GammaMultiplier End If If (m_HasChroma = pcpNo) Then m_HasChroma = pcpInterpreted ' Set default chroma values for sRGB m_WhitePointX = 31270 / ChromaMultiplier m_WhitePointY = 32900 / ChromaMultiplier m_RedX = 64000 / ChromaMultiplier m_RedY = 33000 / ChromaMultiplier m_GreenX = 30000 / ChromaMultiplier m_GreenY = 60000 / ChromaMultiplier m_BlueX = 15000 / ChromaMultiplier m_BlueY = 6000 / ChromaMultiplier End If InterpretSRGBChunk = True End Function Private Function InterpretTextChunk(ByRef inChunk As typPNGChunk) As Boolean Dim LocalStr As String, TextLen As Long ' We assume that the keyword and text must be at least 1 character If (inChunk.pcLength < 3) Then RaiseEvent ParseError(ppeUnexpectedChunkSize) Exit Function End If ' Convert chunk data to local string LocalStr = StrConv(inChunk.pcData(), vbUnicode) ReDim Preserve m_Text(m_NumTexts) As typPNGTextChunk With m_Text(m_NumTexts) ' TrimNull() finds the null-character .ptcKeyword = TrimNull(LocalStr) TextLen = Len(LocalStr) - Len(.ptcKeyword) - 1 If (TextLen > 0) Then .ptcText = TrimNull(Right$(LocalStr, TextLen)) End With m_NumTexts = m_NumTexts + 1 InterpretTextChunk = True End Function Private Function InterpretBackgroundChunk(ByRef inChunk As typPNGChunk) As Boolean Select Case m_ColourType Case 3 ' Palette If (inChunk.pcLength = 1) Then m_Background = inChunk.pcData(0) m_HasBackground = pcpYes InterpretBackgroundChunk = True Else RaiseEvent ParseError(ppeUnexpectedChunkSize) End If Case 0, 4 ' Greyscale If (inChunk.pcLength = 2) Then m_Background = inChunk.pcData(0) m_HasBackground = pcpYes InterpretBackgroundChunk = True Else RaiseEvent ParseError(ppeUnexpectedChunkSize) End If Case 2, 6 ' RGB If (inChunk.pcLength = 6) Then m_Background = RGB(inChunk.pcData(1), inChunk.pcData(3), inChunk.pcData(5)) m_HasBackground = pcpYes InterpretBackgroundChunk = True Else RaiseEvent ParseError(ppeUnexpectedChunkSize) End If End Select End Function Private Function InterpretPhysicalDimsChunk(ByRef inChunk As typPNGChunk) As Boolean If (inChunk.pcLength < 9) Then RaiseEvent ParseError(ppeUnexpectedChunkSize) Exit Function End If m_HasPhysicaDims = pcpYes m_PixelsPerUnitX = MakeDWordFromArr(inChunk.pcData(), 0, True) m_PixelsPerUnitY = MakeDWordFromArr(inChunk.pcData(), 4, True) m_UnitSpecifier = inChunk.pcData(8) InterpretPhysicalDimsChunk = True End Function Private Function InterpretTransparencyChunk(ByRef inChunk As typPNGChunk) As Boolean Dim LoopPal As Long If (m_HasTransparency) Then ' Already got transparency! RaiseEvent ParseError(ppeDuplicateChunkType) Exit Function End If Select Case m_ColourType Case pctGreyscale ' Single colour If (inChunk.pcLength = 2) Then m_TransparentColour = inChunk.pcData(0) m_TransparentColour = m_TransparentColour * &H10101 InterpretTransparencyChunk = True Else RaiseEvent ParseError(ppeUnexpectedChunkSize) End If Case pctRGB ' Single colour If (inChunk.pcLength = 6) Then m_TransparentColour = RGB(inChunk.pcData(0), inChunk.pcData(2), inChunk.pcData(4)) InterpretTransparencyChunk = True Else RaiseEvent ParseError(ppeUnexpectedChunkSize) End If Case pctGreyscaleWithAlpha, pctRGBWithAlpha RaiseEvent ParseError(ppeInvalidChunk) ' Not allowed in full alpha modes Case pctPalette If (inChunk.pcLength > 0) Then For LoopPal = 0 To Min(inChunk.pcLength, m_PalSize) - 1 ' Append high byte to palette data m_Palette(LoopPal) = (m_Palette(LoopPal) And &HFFFFFF) Or ((inChunk.pcData(LoopPal) And &H7F) * &H1000000) If (inChunk.pcData(LoopPal) And &H80) Then m_Palette(LoopPal) = m_Palette(LoopPal) Or &H80000000 Next LoopPal InterpretTransparencyChunk = True Else RaiseEvent ParseError(ppeUnexpectedChunkSize) End If End Select If (InterpretTransparencyChunk) Then m_HasTransparency = pcpYes End Function Private Function InterpretSignificantBit(ByRef inChunk As typPNGChunk) As Boolean Dim RequiredBytes As Long, LoopBytes As Long If (m_HasSignificantBit) Then ' Already got significant bits! RaiseEvent ParseError(ppeDuplicateChunkType) Exit Function End If Select Case m_ColourType Case pctGreyscale: RequiredBytes = 1 Case pctRGB, pctPalette: RequiredBytes = 3 Case pctGreyscaleWithAlpha: RequiredBytes = 2 Case pctRGBWithAlpha: RequiredBytes = 4 End Select If (inChunk.pcLength >= RequiredBytes) Then For LoopBytes = 0 To RequiredBytes - 1 m_SBits(LoopBytes) = inChunk.pcData(LoopBytes) Next LoopBytes m_NumSBit = RequiredBytes InterpretSignificantBit = True m_HasSignificantBit = pcpYes Else RaiseEvent ParseError(ppeUnexpectedChunkSize) End If End Function Private Function IntrepretTimeChunk(ByRef inChunk As typPNGChunk) As Boolean If (m_HasTime) Then ' Already got time! RaiseEvent ParseError(ppeDuplicateChunkType) Exit Function End If If (inChunk.pcLength >= 7) Then ' Convert chunk data to date type m_TimeLastMod = DateSerial((&H100 * inChunk.pcData(0)) + inChunk.pcData(1), inChunk.pcData(2), _ inChunk.pcData(3)) + TimeSerial(inChunk.pcData(4), inChunk.pcData(5), inChunk.pcData(6)) m_HasTime = pcpYes IntrepretTimeChunk = True Else RaiseEvent ParseError(ppeUnexpectedChunkSize) End If End Function Private Function TrimNull(ByRef inString As String) As String Dim NullPos As Long NullPos = InStr(1, inString, vbNullChar) If (NullPos) Then TrimNull = Left$(inString, NullPos - 1) Else TrimNull = inString End Function Private Function Min(ByVal inA As Long, ByVal inB As Long) As Long If (inA < inB) Then Min = inA Else Min = inB End Function Private Function MakeDWordFromArr(ByRef inArr() As Byte, _ Optional ByVal inOffset As Long = 0, _ Optional ByVal inFlip As Boolean = False) As Long Dim ArrSize As Long If (inOffset < 0) Then Exit Function On Error Resume Next ArrSize = UBound(inArr()) On Error GoTo 0 If (inOffset > (ArrSize - 3)) Then Exit Function If (inFlip) Then MakeDWordFromArr = MakeDWord(inArr(inOffset + 3), _ inArr(inOffset + 2), inArr(inOffset + 1), inArr(inOffset)) Else MakeDWordFromArr = MakeDWord(inArr(inOffset), _ inArr(inOffset + 1), inArr(inOffset + 2), inArr(inOffset + 3)) End If End Function Private Function MakeDWord(ByVal inA As Byte, ByVal inB As Byte, ByVal inC As Byte, ByVal inD As Byte) As Long MakeDWord = (&H1000000 * (inD And &H7F)) Or (&H10000 * inC) Or (&H100& * inB) Or inA If (inD And &H80) Then MakeDWord = MakeDWord Or &H80000000 End Function Private Function DWordToFourCC(ByVal inDWord As Long) As String DWordToFourCC = Chr$(inDWord And &HFF&) & Chr$((inDWord And &HFF00&) \ &H100&) & Chr$((inDWord And &HFF0000) \ &H10000) & _ Chr$(((inDWord And &H7F000000) \ &H1000000) Or IIf(inDWord And &H80000000, &H80&, 0&)) End Function Private Function FourCCToDWord(ByVal inFourCC As String) As Long Dim Chars() As Byte If (Len(inFourCC) > 4) Then Exit Function Chars() = StrConv(inFourCC & String$(4 - Len(inFourCC), vbNullChar), vbFromUnicode) FourCCToDWord = MakeDWord(Chars(0), Chars(1), Chars(2), Chars(3)) End Function Private Function FlipDWord(ByVal inDWord As Long) As Long FlipDWord = (((inDWord And &HFF000000) \ &H1000000) And &HFF) Or ((inDWord And &HFF0000) \ &H100) Or _ ((inDWord And &HFF00&) * &H100) Or ((inDWord And &H7F) * &H1000000) If (inDWord And &H80) Then FlipDWord = FlipDWord Or &H80000000 End Function Private Sub ClearInfo() Dim LoopData As Long m_FileName = vbNullString m_FileSize = 0 m_Width = 0 m_Height = 0 m_ChannelDepth = 0 m_ColourType = 0 m_Interlace = piNone m_PalSize = 0 m_Gamma = 0 m_SRGBRenderingIntent = 0 m_NumTexts = 0 m_Background = 0 m_PixelsPerUnitX = 0 m_PixelsPerUnitY = 0 m_UnitSpecifier = pusUnknown m_TransparentColour = 0 m_NumSBit = 0 m_TimeLastMod = 0 m_WhitePointX = 0 m_WhitePointY = 0 m_RedX = 0 m_RedY = 0 m_GreenX = 0 m_GreenY = 0 m_BlueX = 0 m_BlueY = 0 m_HasGamma = pcpNo m_HasPalette = pcpNo m_HasChroma = pcpNo m_HassRGB = pcpNo m_HasBackground = pcpNo m_HasPhysicaDims = pcpNo m_HasHeader = pcpNo m_HasFooter = pcpNo m_HasTransparency = pcpNo m_HasSignificantBit = pcpNo m_HasTime = pcpNo Erase m_Palette() Erase m_Text() For LoopData = 0 To 3 m_SBits(LoopData) = 0 Next LoopData End Sub Private Function FileExist(ByRef inFile As String) As Boolean On Error Resume Next FileExist = CBool(FileLen(inFile) + 1) End Function Private Sub MakeCRCTable() Dim c As Long Dim n As Long, k As Long If (GotCRCTable) Then Exit Sub For n = 0 To &HFF c = n For k = 0 To 7 If (c And &H1) Then c = &HEDB88320 Xor (((c And &HFFFFFFFE) \ &H2) And &H7FFFFFFF) Else c = ((c And &HFFFFFFFE) \ &H2) And &H7FFFFFFF End If Next k CRCTable(n) = c Next n GotCRCTable = True End Sub ' 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 Private Function UpdateCRC(ByVal CRC As Long, ByRef Buf() As Byte, ByVal BufLen As Long) As Long Dim c As Long Dim n As Long c = CRC For n = 0 To BufLen - 1 c = CRCTable((c Xor Buf(n)) And &HFF) Xor _ (((c And &HFFFFFF00) \ &H100) And &HFFFFFF) Next n UpdateCRC = c End Function