cpngparser.cls

AeroSuite--一组非常漂亮的VISTA控件集

    '   a nice 8x8 grid evenly.
    ' Each scanline in interlaced image is also filtered, but they are filtered in relation
    ' to only the other scanlines in the same pass, different than non-interlaced images.
    ' Think of non-interlaced images as single-pass interlaced images.

    ' counter variables
    Dim Pass As Byte, srcRow As Long
    ' sizing/bit alignment variables
    Dim nr8wide As Long, nr8high As Long
    Dim nrBytes As Long, passPtr As Long
    Dim InterlacePass() As Byte  ' unfiltered progressive display (used 7x for 7 passes)
    ' bytes and bits per pixel values
    Dim bytesPP As Byte, BPRow As Long, bitPP As Byte
    
    ' need bit & byte information
    GetDepthInfo 0, 0, bitPP, bytesPP
    
    ' oversize array for "pass" bytes to prevent reszing array on each pass
    BPRow = GetBytesPerPixel((m_Width \ m_MatrixDat(7, MatrixColAdd)), bitPP)
    ' how many bytes are needed for the final pass; largest pass size in bytes
    nrBytes = (BPRow + 1) * (m_Height \ m_MatrixDat(7, MatrixRowAdd))
    ReDim InterlacePass(0 To nrBytes - 1&)

    ' interlaced images always come in 7 passes; although not all passes may be used
    For Pass = 1 To 7
        ' ensure bounds are valid. If image is smaller than 8x8 not all passes are valid/used
        ' Tested with images as small as 1x1
    
        ' calculate nr of pixels for this pass that will fit in width of image
        nr8wide = m_Width \ m_MatrixDat(Pass, MatrixColAdd) - (m_Width Mod m_MatrixDat(Pass, MatrixColAdd) > m_MatrixDat(Pass, MatrixCol))
        If nr8wide > 0& Then
            
            ' calcuate nr of rows for this pass that will fit in height of image
            nr8high = m_Height \ m_MatrixDat(Pass, MatrixRowAdd) - (m_Height Mod m_MatrixDat(Pass, MatrixRowAdd) > m_MatrixDat(Pass, MatrixRow))
            If nr8high > 0& Then
    
                ' calculate row bytes for the interlaced image, byte aligned
                BPRow = GetBytesPerPixel(nr8wide, bitPP) + 1&
                ' how many bytes are needed for the complete pass, less filter byte?
                nrBytes = BPRow * nr8high
                '^^ the filter routines expect the filter byte to be in its parameters, so add it
                
                ' unfilter the scanlines
                CopyMemory InterlacePass(0), Filtered(passPtr), nrBytes
                For srcRow = 0& To nr8high - 1&
                    Select Case Filtered(BPRow * srcRow + passPtr)
                    Case 0: ' no filtering
                    Case 1: ' sub filter
                        DecodeFilter_Sub InterlacePass, srcRow, BPRow, bytesPP
                    Case 2: ' up filter
                        DecodeFilter_Up InterlacePass, srcRow, BPRow, 0
                    Case 3: ' average filter
                        DecodeFilter_Avg InterlacePass, srcRow, BPRow, bytesPP
                    Case 4: ' paeth filter
                        DecodeFilter_Paeth InterlacePass, srcRow, BPRow, bytesPP
                    Case Else
                        ' If we got here, there is a different filtering mechanism at large
                        Exit Function
                    End Select
                Next
        
                ' offset the filtered array pointer to account for the 1byte filter flag per scanline
                ' This will point to the next pass's X,Y position in the Unfiltered() array
                passPtr = passPtr + nrBytes
            
                ' send unfiltered array to be transfered to the DIB
                ' color formats broken into different routines to help speed up transfering
                Select Case m_ColorType
                Case clrTrueAlpha, clrGrayAlpha, clrTrueColor
                    If m_BitDepth < 16& Then
                        If ConvertPNGtoBMP_NonPalette(InterlacePass(), Pass, nr8high, BPRow) = False Then Exit Function
                    Else
                        If ConvertPNGtoBMP_16Bit(InterlacePass(), Pass, nr8high, BPRow) = False Then Exit Function
                    End If
                Case clrPalette, clrGrayScale
                    If m_BitDepth < 16& Then
                        If ConvertPNGtoBMP_Palettes(InterlacePass(), Pass, nr8high, BPRow) = False Then Exit Function
                    Else
                        If ConvertPNGtoBMP_16Bit(InterlacePass(), Pass, nr8high, BPRow) = False Then Exit Function
                    End If
                End Select
            End If ' check for nr8high < 1
        End If ' check for nr8wide < 1
    
    Next Pass

    UnfilterInterlaced = True
    
End Function

Private Function UnfilterNI(filteredData() As Byte) As Boolean

    ' // LaVolpe, Dec 1 thru 10 - completely rewritten to remove excess large array usage
    ' http://www.w3.org/TR/PNG/#9-table91

    Dim Row As Long, BPRow As Long
    Dim lBpp As Byte, stepVal As Byte
    
    GetDepthInfo 0, 0, lBpp, stepVal
    BPRow = GetBytesPerPixel(m_Width, lBpp) + 1&
    '^^ the filtered row contains an extra byte (1st byte of each row)
    '   that identifies the filter algorithm used for that row
    
    For Row = 0& To m_Height - 1&

        Select Case filteredData(BPRow * Row)
        Case 0 'no filtering
        Case 1 'Sub
            DecodeFilter_Sub filteredData, Row, BPRow, stepVal
        Case 2 'Up
            DecodeFilter_Up filteredData, Row, BPRow, 0
        Case 3 'Average
            DecodeFilter_Avg filteredData, Row, BPRow, stepVal
        Case 4 'Paeth
            DecodeFilter_Paeth filteredData, Row, BPRow, stepVal
        Case Else
            ' invalid filter type; no action
        End Select
        
    Next Row
    
    ' color formats broken into different routines to help speed up transferring
    Select Case m_ColorType
    Case clrTrueAlpha, clrGrayAlpha, clrTrueColor
        If m_BitDepth < 16& Then
            UnfilterNI = ConvertPNGtoBMP_NonPalette(filteredData(), 8, Row, BPRow, 0)
        Else
            UnfilterNI = ConvertPNGtoBMP_16Bit(filteredData(), 8, Row, BPRow, 0)
        End If
    Case clrPalette, clrGrayScale
        If m_BitDepth < 16& Then
            UnfilterNI = ConvertPNGtoBMP_Palettes(filteredData(), 8, Row, BPRow, 0)
        Else
            UnfilterNI = ConvertPNGtoBMP_16Bit(filteredData(), 8, Row, BPRow, 0)
        End If
    End Select
    
End Function

Private Function zChunk_IHDR(bufLen As Long, streamOffset As Long, cmprSize As Long, crcValue As Long) As Long
                
    ' IHDR structure
    '    Width As Long              << cannot be negative
    '    Height As Long             << cannot be negative
    '    BitDepth As Byte           << must be 1,2,4,8,16
    '    ColorType As Byte          << must be 0,2,3,4,6
    '    Compression As Byte        << must be zero
    '    Filter As Byte             << must be zero
    '    Interlacing As Byte        << must be zero or one
    
    On Error Resume Next
    Dim lRtn As Long, lValue As Long
    
    If Not crcValue = 0& Then
        lRtn = Not (zCheckCRCvalue(VarPtr(pngStream(streamOffset)), bufLen + 4&, crcValue))
    End If
    If lRtn = 0& Then
        
        CopyMemory m_Width, pngStream(streamOffset + 4&), 4&
        m_Width = iparseReverseLong(m_Width)
        CopyMemory m_Height, pngStream(streamOffset + 8&), 4&
        m_Height = iparseReverseLong(m_Height)
        
        If m_Width < 1& Or m_Height < 1& Then
            lRtn = 1& 'Corrupted Image Header. Cannot continue.
        
        Else
            
            If Not pngStream(streamOffset + 14&) = 0 Then
                lRtn = 1& ' Invalid Compression Flag in Header. Cannot continue.
            Else
                If Not pngStream(streamOffset + 15&) = 0 Then
                    lRtn = 1& 'Invalid Filter Flag in Header. Cannot continue.
                Else
                    
                    m_BitDepth = pngStream(streamOffset + 12&)
                    Select Case m_BitDepth
                    Case 1&, 2&, 4&, 8&, 16&
                        ' it is a valid bit depth
                        m_ColorType = pngStream(streamOffset + 13&)
                        Select Case m_ColorType
                        Case 0&, 2&, 3&, 4&, 6&
                            ' it is a valid color type
                            m_Interlacing = pngStream(streamOffset + 16&)
                            If m_Interlacing > 1& Then
                                lRtn = 1& 'Invalid Interlacing Flag in Header. Cannot continue.
                            End If
                        Case Else
                            lRtn = 1& 'Invalid Color Type Flag in Header. Cannot continue.
                        End Select
                    Case Else
                        lRtn = 1& 'Invalid Bit Depth Flag in Header. Cannot continue.
                    End Select
                    
                End If  ' Filter flag
            End If  ' Compression flag
        End If  ' Dimensions
        
        If lRtn = 0& Then
            ' check for png sizes that would cause overflow errors in other calculations...
            ' This has 2 basic checks
            ' check DWord width alignment * height first are within bounds
            lValue = 32& * m_Width * m_Height     ' max number of bytes needed for DIB
            ' see if uncompress png data is too long
            If Not Err Then
                cmprSize = CalcUncompressedWidth()
            End If
            If Err Then
                Err.Clear
                lRtn = 1&
            End If
        End If
    End If

    zChunk_IHDR = lRtn

End Function

Private Function zChunk_PLTE(bufLen As Long, streamOffset As Long, crcValue As Long) As Long

    ' http://www.w3.org/TR/PNG/#11PLTE
    If m_ColorType = 0& Or m_ColorType = 4& Then Exit Function
    '^^ per specs, palettes shall not appear for those color types
    '   Since we can ignore the palette, we won't trigger a critcal error
    
    Dim lRtn As Long
    If Not crcValue = 0& Then
        lRtn = Not (zCheckCRCvalue(VarPtr(pngStream(streamOffset)), bufLen + 4&, crcValue))
    End If
    If lRtn = 0& Then
        
        ' per png specs, palette must be divisible by 3
        If bufLen Mod 3& = 0& Then
            ReDim m_Palette(0 To bufLen - 1&)
            CopyMemory m_Palette(0), pngStream(streamOffset + 4&), bufLen
        Else ' error
            lRtn = 1& 'Invalid Palette. Cannot continue.
        End If
    End If
    zChunk_PLTE = lRtn

End Function

Private Function zChunk_tRNS(bufLen As Long, streamOffset As Long, crcValue As Long) As Long
'http://www.w3.org/TR/PNG/#11tRNS
    
    If m_ColorType > clrPalette Then Exit Function
    ' Per specs, the tRNS chunk shall not be used for Color Types 4 and 6

    On Error GoTo ExitMe
    Dim UB As Long, palIndex As Byte, lRtn As Long
    
    If Not crcValue = 0& Then
        lRtn = Not (zCheckCRCvalue(VarPtr(pngStream(streamOffset)), bufLen + 4, crcValue))
    End If
    If lRtn = 0& Then
        
        ' we will ensure the passed array is dimensioned properly and also cache
        ' the simple transparency color for easier reference while processing
        
        ReDim m_TransSimple(0 To bufLen - 1&)
        CopyMemory m_TransSimple(0), pngStream(streamOffset + 4&), bufLen
    
        If m_ColorType = clrGrayScale Then ' grayscale with simple transparency
            ' least significant bits used. Tweak array to hold only those bits in byte format
            m_TransColor = m_TransSimple(1) ' color-index value not a color
            
        ElseIf m_ColorType = clrTrueColor Then ' rgb triple (true color)
            ' save as BGR to be compared against PNG samples
            m_TransColor = m_TransSimple(5) Or m_TransSimple(3) * &H100& Or m_TransSimple(1) * &H10000
            ' for 16bpp PNGs, the 0,2,4 array elements are needed also but will be tested in ConvertPngToBmp
            
        ElseIf m_ColorType = clrPalette Then ' TransSimple() is an array
            ' This array is directly related to the Palette. Each palette entry
            ' will have a related TransSimple() entry. Exception: When Palette entries
            ' are sorted (in ascending order of alpha value), then any Palette entries
            ' that have alpha values of 255 probably will not be in that related array.
            ' In these cases, we will fake it & provide the missing entries.
        
            ' to prevent out of bounds errors, ensure array is 255
            If UBound(m_TransSimple) < 255& Then ' pngs are not required to provide all
                UB = UBound(m_TransSimple)
                ReDim Preserve m_TransSimple(0 To 255)    ' prevent out ouf bounds errors
                FillMemory m_TransSimple(UB + 1&), 255& - UB, 255
            End If
            m_TransColor = 0& ' simply a flag > -1, has no other meaning
        End If
        
        If Err Then
            Err.Clear   ' an error regarding the TransSimple() array