cpngparser.cls

很棒的网页音乐播放器,可以嵌入网页。界面很漂亮

    nrBytes = (BPRow + 1) * (m_Height \ MatrixRowAdd(7))
    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 \ MatrixColAdd(Pass) - (m_Width Mod MatrixColAdd(Pass) > MatrixCol(Pass))
        If nr8wide > 0 Then
            
            ' calcuate nr of rows for this pass that will fit in height of image
            nr8high = m_Height \ MatrixRowAdd(Pass) - (m_Height Mod MatrixRowAdd(Pass) > MatrixRow(Pass))
            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 pngStream(streamOffset + 14) > 0 Then
                lRtn = 1 ' Invalid Compression Flag in Header. Cannot continue.
            Else
                If 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 = ((((m_Width * 32) + &H1F) And Not &H1F&) \ &H8) * m_Height
            ' see if uncompress png data is too long
            If Not Err Then cmprSize = CalcUncompressedWidth()
            If cmprSize = 0 Then
                If Err Then Err.Clear
                ' either the dWord aligned bytes required for the bitmap
                ' are too large (Long value) or the size of the total
                ' uncompressed pixel array is too large (Long value).
                ' Image is way too big to process anyway! would require GBs of memory
                lRtn = 1 'Image is too large to process. Cannot continue.
            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 \ 3) * 3 = bufLen Then
            ReDim m_Palette(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) * 256& Or m_TransSimple(1) * 65536
            ' 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
            m_TransColor = -1 ' no transparency color
        End If
    
    End If

ExitMe:
End Function

Private Sub InitializePalette()

    ' Purpose: Create a palette for the PNG file, if needed
    ' The colors from the palette will be transfered to the 32bpp image

    If m_ColorType = clrPalette Or m_ColorType = clrGrayScale Then
    
        Dim nrEntries As Long, stepVal As Long
        Dim X As Long, Index As Long, Color As Long

        ' PNG grayscale palettes are not provided, they are assumed...
        If iparseIsArrayEmpty(Not m_Palette) Then
            
            ReDim m_Palette(0 To 767)
            If m_ColorType = clrGrayScale Then
            
                nrEntries = pow2x8(m_BitDepth) - 1      ' number grayscale palette entries