cpngwriter.cls

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

                    CopyMemory Stream(Index), rwLen, 4&
                    CopyMemory Stream(Index + 4&), pngData(1), gpLong
                    rwLen = zCreateCRC(VarPtr(pngData(1)), gpLong)
                    CopyMemory Stream(Index + gpLong + 4&), rwLen, 4&
                    Write_zTXt = True
                Else
                    WriteFile fileNum, iparseReverseLong(gpLong - 4&), 4&, rwLen, ByVal 0&
                    If rwLen = 4& Then
                        WriteFile fileNum, pngData(1), gpLong, rwLen, ByVal 0&
                        If rwLen = gpLong Then
                            WriteFile fileNum, zCreateCRC(VarPtr(pngData(1)), gpLong), 4&, rwLen, ByVal 0&
                            Write_zTXt = (rwLen = 4&)
                        End If
                    End If
                End If
            End If
        Next
    Else
        Write_zTXt = True
    End If
    
eh:
    If Err Then Err.Clear

End Function

Private Function Write_bKGD(fileNum As Long, Stream() As Byte) As Boolean

    ' For paletted/grayscale images, this is the palette index, otherwise RGB value
    On Error GoTo eh
    Const chnk_bKGD As Long = &H44474B62 'Window Background Color
    
    If (m_PNGprops And ePngProperties.colorDefaultBkg) = ePngProperties.colorDefaultBkg Then
    
        Dim pngData() As Byte
        Dim gpLong As Long
        Dim rwLen As Long
        Dim Index As Long
            
        ' Per PNG specs, bKGD chunk must come before IDAT and after PLTE
        Select Case m_ColorType
        Case clrPalette  ' 1 byte + 4 byte chunk name
            ReDim pngData(0 To 4)
            pngData(4) = CByte(m_bKGD)
        
        Case clrGrayScale, clrGrayAlpha   ' grayscales, 2 bytes + 4 byte chunk name
            ReDim pngData(0 To 6)
            pngData(5) = (m_bKGD And &HFF)
            ' pngData(4) used with 48bit per pixel images (not supported)
            
        Case Else ' true color, RGB format
            ReDim pngData(0 To 9)   ' 6 bytes + 4 byte chunk name
            pngData(5) = m_bKGD And &HFF
            pngData(7) = (m_bKGD \ &H100&) And &HFF
            pngData(9) = (m_bKGD \ &H10000) And &HFF
            ' Note: pngData(4,6,8) used with 48bit per pixel images (not supported)
        End Select
        
        CopyMemory pngData(0), chnk_bKGD, 4&
        gpLong = UBound(pngData) + 1&
        
        If fileNum = 0& Then 'writing to array
            Index = UBound(Stream) + 1&
            ReDim Preserve Stream(0 To Index + gpLong + 7&)
            rwLen = iparseReverseLong(gpLong - 4&)
            CopyMemory Stream(Index), rwLen, 4&
            CopyMemory Stream(Index + 4&), pngData(0), gpLong
            rwLen = zCreateCRC(VarPtr(pngData(0)), gpLong)
            CopyMemory Stream(Index + gpLong + 4&), rwLen, 4&
            Write_bKGD = True
        Else
            WriteFile fileNum, iparseReverseLong(gpLong - 4&), 4&, rwLen, ByVal 0&
            If rwLen = 4& Then
                WriteFile fileNum, pngData(0), gpLong, rwLen, ByVal 0&
                If rwLen = gpLong Then
                    WriteFile fileNum, zCreateCRC(VarPtr(pngData(0)), gpLong), 4&, rwLen, ByVal 0&
                    Write_bKGD = (rwLen = 4&)
                End If
            End If
        End If
    Else
        Write_bKGD = True
    End If
eh:
    If Err Then Err.Clear
        
End Function

Private Function Write_IDAT(fileNum As Long, outStream() As Byte, imgData() As Byte, filterLen As Long) As Boolean

    ' Function writes the IDAT chunk(s). If more than one, they must be back to back
    ' Note: IDATs can be written in multiple chunks; if so, chunks must be consecutive

    Const chnk_IDAT As Long = &H54414449 'Image data
    
    On Error GoTo eh
    Dim gpLong As Long, Index As Long
    Dim rwLen As Long
    
    CopyMemory imgData(0), chnk_IDAT, 4&
    If fileNum = 0& Then ' writing to array vs file
        Index = UBound(outStream) + 1&
        ReDim Preserve outStream(0 To Index + filterLen + 11&)
        gpLong = iparseReverseLong(filterLen)
        CopyMemory outStream(Index), gpLong, 4&  ' add chunk size
        CopyMemory outStream(Index + 4&), imgData(0), filterLen + 4& ' add compressed data
        gpLong = zCreateCRC(VarPtr(imgData(0)), filterLen + 4&)
        CopyMemory outStream(Index + 8& + filterLen), gpLong, 4& ' add crc value
        Write_IDAT = True
    Else
        
        WriteFile fileNum, iparseReverseLong(filterLen), 4&, rwLen, ByVal 0&
        If rwLen = 4& Then
            WriteFile fileNum, imgData(0), filterLen + 4&, rwLen, ByVal 0&
            If rwLen = filterLen + 4& Then
                WriteFile fileNum, zCreateCRC(VarPtr(imgData(0)), rwLen), 4&, rwLen, ByVal 0&
                Write_IDAT = (rwLen = 4&)
            End If
        End If
    End If
eh:
    If Err Then Err.Clear

End Function

Private Function Write_IEND(fileNum As Long, Stream() As Byte) As Boolean

    Const chnk_IEND As Long = &H444E4549 'End of Image
    
    On Error GoTo eh
    Dim Index As Long
    Dim gpLong As Long
    Dim rwLen As Long
    
    If fileNum = 0 Then ' writing to array vs file
    
        Index = UBound(Stream) + 1&
        ReDim Preserve Stream(0 To Index + 11&)
        CopyMemory Stream(Index), 0&, 4&
        CopyMemory Stream(Index + 4), chnk_IEND, 4&   ' chunk name, chunk length is zero
        gpLong = zCreateCRC(VarPtr(chnk_IEND), 4&)
        CopyMemory Stream(Index + 8&), gpLong, 4&    ' crc value
        Write_IEND = True
    Else
    
        WriteFile fileNum, rwLen, 4&, rwLen, ByVal 0&
        If rwLen = 4& Then
            WriteFile fileNum, chnk_IEND, 4&, rwLen, ByVal 0&
            If rwLen = 4& Then
                WriteFile fileNum, zCreateCRC(VarPtr(chnk_IEND), 4&), 4&, rwLen, ByVal 0&
                Write_IEND = (rwLen = 4&)
            End If
        End If
    End If
eh:
    If Err Then Err.Clear

End Function

Private Sub EncodeFilter_None(pngData() As Byte, _
                        ByVal RowNr As Long, dibRowNr As Long, _
                        ByVal scanLineDIB As Long, scanLinePNG As Long, _
                        stepVal As Byte, AdptValue As Long)

    ' this routine is only called when adapative filter method is used
    
    Dim X As Long
    Dim startByte As Long, locDIB As Long
    Dim lTest As Long
    
    If scanLineDIB > -1 Then ' processing interlaced image
        ' for interlaced, m_Uncompressed will be a top-down calculated array
        ' and the scanLineDIB parameter is an offset into the interlaced array
        startByte = scanLineDIB + 1
        locDIB = startByte
    Else
        ' for non-interlaced, m_Uncompressed will be a bottom-up DIB
        locDIB = dibRowNr * -scanLineDIB
        startByte = RowNr * scanLinePNG + RowNr + 1
   End If
    
    For X = locDIB To locDIB + scanLinePNG - 1
        lTest = lTest + m_Uncompressed(X)
        If lTest > AdptValue Then Exit Sub
    Next
    
    If lTest = 0 Then lTest = 1
    AdptValue = lTest
    pngData(startByte - 1) = 0

End Sub


Private Sub EncodeFilter_Up(pngData() As Byte, _
                        ByVal RowNr As Long, dibRowNr As Long, _
                        ByVal scanLineDIB As Long, scanLinePNG As Long, _
                        stepVal As Byte, AdptValue As Long)

' this is Filter Type 2
'http://www.w3.org/TR/PNG/#9-table91
    
    Dim ppTop As Integer
    Dim X As Long
    Dim startByte As Long, locDIB As Long
    Dim lTest As Long, prevRow As Long
    
    If scanLineDIB > -1 Then ' processing interlaced image
        ' for interlaced, m_Uncompressed will be a top-down calculated array
        ' and the scanLineDIB parameter is an offset into the interlaced array
        startByte = scanLineDIB + 1
        scanLineDIB = scanLinePNG + 1
        locDIB = startByte
    Else
        ' for non-interlaced, m_Uncompressed will be a bottom-up DIB
        locDIB = dibRowNr * -scanLineDIB
        startByte = RowNr * scanLinePNG + RowNr + 1
    End If
        
    If AdptValue Then
        
        If RowNr Then
            For X = locDIB To locDIB + scanLinePNG - 1
                lTest = lTest + Abs(0 + m_Uncompressed(X) - m_Uncompressed(X - scanLineDIB))
                If lTest > AdptValue Then Exit Sub
            Next
            
            If lTest = 0 Then lTest = 1
            AdptValue = lTest
            pngData(startByte - 1) = 2
        End If
        
    Else
        For X = 0 To scanLinePNG - 1
            If RowNr Then ppTop = m_Uncompressed(locDIB + X - scanLineDIB)
            ' VB workaround for C++ unsigned math
            If ppTop > m_Uncompressed(locDIB + X) Then
                pngData(startByte + X) = 256 - ppTop + m_Uncompressed(locDIB + X)
            Else
                pngData(startByte + X) = m_Uncompressed(locDIB + X) - ppTop
            End If
        Next
        pngData(startByte - 1) = 2
    End If

End Sub

Private Sub EncodeFilter_Sub(pngData() As Byte, _
                        ByVal RowNr As Long, dibRowNr As Long, _
                        ByVal scanLineDIB As Long, scanLinePNG As Long, _
                        stepVal As Byte, AdptValue As Long)

' This is Filter Type 1
'http://www.w3.org/TR/PNG/#9-table91

    Dim X As Long
    Dim startByte As Long, locDIB As Long
    Dim lTest As Long
    
    If scanLineDIB > -1 Then ' processing interlaced image
        ' for interlaced, m_Uncompressed will be a top-down calculated array
        ' and the scanLineDIB parameter is an offset into the interlaced array
        startByte = scanLineDIB + 1
        scanLineDIB = scanLinePNG + 1
        locDIB = startByte
    Else
        ' for non-interlaced, m_Uncompressed will be a bottom-up DIB
        locDIB = dibRowNr * -scanLineDIB
        startByte = RowNr * scanLinePNG + RowNr + 1
    End If
        
    If AdptValue Then
    
        ' 1st n bytes for 1st pixel are unfiltered
        For X = locDIB To stepVal + locDIB - 1
            lTest = lTest + m_Uncompressed(X)
        Next
        
        For X = locDIB + stepVal To scanLinePNG - 1
            lTest = lTest + Abs(0 + m_Uncompressed(X) - m_Uncompressed(X - stepVal))
            If lTest > AdptValue Then Exit Sub
        Next
        
        If lTest = 0 Then lTest = 1
        AdptValue = lTest
        
    Else
        ' 1st n bytes for 1st pixel are unfiltered
        CopyMemory pngData(startByte), m_Uncompressed(locDIB), stepVal
        
        For X = stepVal To scanLinePNG - 1
            ' VB workaround for C++ unsigned math
            If m_Uncompressed(locDIB + X - stepVal) > m_U