cpngwriter.cls

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

            Case txtWarning: Index = 7&
                keyWord = "Warning" & Chr$(0)
            End Select
                
            ' tXTt chunk format::
            'Keyword 1-79 bytes (character string)
            'Null separator 1 byte (null character)
            'Text string 0 or more bytes (character string)
            
            lenKeyword = Len(keyWord)
            txtData() = StrConv(keyWord, vbFromUnicode)
            If Len(m_Captions(Index)) > 0& Then
                lenText = Len(m_Captions(Index))
                ReDim pngData(1 To lenKeyword + lenText + 4&)
                CopyMemory pngData(5), txtData(0), lenKeyword
                txtData() = StrConv(m_Captions(Index), vbFromUnicode)
                CopyMemory pngData(5& + lenKeyword), txtData(0), lenText
                
            Else ' handle zero-length chunks.
                ' Note: I would prefer to just skip these, but maybe you might
                ' decide to use one as a flag for something else?
                ReDim pngData(1 To lenKeyword + 4&)
                CopyMemory pngData(5), txtData(0), lenKeyword
            End If
            CopyMemory pngData(1), chnk_tEXt, 4&
            gpLong = lenKeyword + lenText + 4&
            
            If fileNum = 0& Then ' writing to stream
                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(1), gpLong
                rwLen = zCreateCRC(VarPtr(pngData(1)), gpLong)
                CopyMemory Stream(Index + 4& + gpLong), rwLen, 4&
                Write_tEXt = 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_tEXt = (rwLen = 4&)
                    End If
                End If
            End If
        End If
        CaptionID = CaptionID * 2&
    Loop
    
ExitRoutine:
    If Err Then
        Err.Clear
    Else
        If lenKeyword = 0& Then Write_tEXt = True
    End If

End Function

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

    ' Note: the time stamp should be Universal Time, not local area
    
    If (m_PNGprops And ePngProperties.dateTimeModified) = ePngProperties.dateTimeModified Then

        Const chnk_tIME As Long = &H454D4974 'Timestamp
        
        On Error GoTo eh
        Dim pngData(0 To 10) As Byte ' 7 byte date/time + 4 byte chunk name
        Dim gpLong As Long
        Dim gpInt As Integer
        Dim dtStamp As Date
        Dim rwLen As Long
        
        dtStamp = CDate(m_Captions(10))
        
        CopyMemory pngData(0), chnk_tIME, 4&
            gpInt = Year(dtStamp)
        CopyMemory pngData(5), gpInt, 2&
        pngData(4) = pngData(6)             ' swap endian of integer
            gpInt = Month(dtStamp)
        CopyMemory pngData(6), gpInt, 1&
            gpInt = Day(dtStamp)
        CopyMemory pngData(7), gpInt, 1&
            gpInt = Hour(dtStamp)
        CopyMemory pngData(8), gpInt, 1&
            gpInt = Minute(dtStamp)
        CopyMemory pngData(9), gpInt, 1&
            gpInt = Second(dtStamp)
        CopyMemory pngData(10), gpInt, 1&
        
        If fileNum = 0& Then ' writing to stream
            gpLong = UBound(Stream) + 1&
            ReDim Preserve Stream(0 To gpLong + 18&)
            rwLen = iparseReverseLong(7)
            CopyMemory Stream(gpLong), rwLen, 4&
            CopyMemory Stream(gpLong + 4&), pngData(0), 11&
            rwLen = zCreateCRC(VarPtr(pngData(0)), 11&)
            CopyMemory Stream(gpLong + 15&), rwLen, 4&
            Write_tIMe = True
        Else
            WriteFile fileNum, iparseReverseLong(7), 4&, rwLen, ByVal 0&
            If rwLen = 4& Then
                WriteFile fileNum, pngData(0), 11&, rwLen, ByVal 0&
                If rwLen = 11& Then
                    WriteFile fileNum, zCreateCRC(VarPtr(pngData(0)), rwLen), 4&, rwLen, ByVal 0&
                    Write_tIMe = (rwLen = 4&)
                End If
            End If
        End If
    Else
        Write_tIMe = True
    End If
eh:
    If Err Then Err.Clear

End Function

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

    ' For paletted/grayscale images, tRNS is the palette index, otherwise RGB value
    On Error GoTo eh
        
    If m_Trans = -1& Then
        Write_tRNS = True
    
    Else ' transparency not used
    
        Const chnk_tRNS As Long = &H534E5274 'Simple Transparency & palette transparency
        Dim Index As Long
        Dim gpLong As Long
        Dim rwLen As Long
    
        Select Case m_ColorType
            
            Case clrPalette ' Paletted (palette count * 3 + 4 byte chunk name)
                ' nothing to do; done during PalettizeImage
            
            Case clrGrayScale ' grayscale
                ReDim m_transPal(1 To 6)   ' 2 bytes + 4 byte chunk name
                m_transPal(6) = m_Trans
                ' Note: m_transPal(5) used with 48bit per pixel images (not supported)
            
            Case clrTrueColor ' we have simple transparency for true color
                ReDim m_transPal(1 To 10)   ' 6 bytes + 4 byte chunk name
                m_transPal(6) = m_Trans And &HFF
                m_transPal(8) = (m_Trans \ &H100&) And &HFF
                m_transPal(10) = (m_Trans \ &H10000) And &HFF
                ' Note: m_transPal(5,7,9) used with 48bit per pixel images (not supported)
        
            Case Else
                ' Color Types 4 & 6 are prohibited from having a tRNS chunk
                Write_tRNS = True
                Exit Function
        End Select
        
        CopyMemory m_transPal(1), chnk_tRNS, 4&
        gpLong = UBound(m_transPal)
    
        ' write the chunk
        If fileNum = 0& Then ' writing to array vs file
            Index = UBound(Stream) + 1&
            ReDim Preserve Stream(0 To Index + gpLong + 7&)
            rwLen = iparseReverseLong(gpLong - 4&)
            CopyMemory Stream(Index), rwLen, 4&                 ' chunk size
            CopyMemory Stream(Index + 4&), m_transPal(1), gpLong ' palette
            gpLong = zCreateCRC(VarPtr(m_transPal(1)), gpLong)
            CopyMemory Stream(Index + UBound(m_transPal) + 4&), gpLong, 4&       ' crc value
            Write_tRNS = True
        Else
            WriteFile fileNum, iparseReverseLong(gpLong - 4&), 4&, rwLen, ByVal 0&
            If rwLen = 4& Then
                WriteFile fileNum, m_transPal(1), gpLong, rwLen, ByVal 0&
                If rwLen = gpLong Then
                    WriteFile fileNum, zCreateCRC(VarPtr(m_transPal(1)), gpLong), 4&, rwLen, ByVal 0&
                    Write_tRNS = (rwLen = 4&)
                End If
            End If
        End If
        Erase m_transPal()
    End If
eh:
    If Err Then Err.Clear

End Function

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

    ' Function writes non-reserved keyword compressed/uncompressed text to the PNG
    
    If (m_PNGprops And ePngProperties.txtLargeBlockText) = ePngProperties.txtLargeBlockText Then

        On Error GoTo eh

        Const chnk_tEXt As Long = &H74584574 'Text - uncompressed
        Const chnk_zTXt As Long = &H7458547A 'Text - compressed
        
        Dim txtData() As Byte   ' comments/text in bytes
        Dim pngData() As Byte   ' data to be written to PNG file
        Dim sText As String
        Dim gpLong As Long
        Dim Index As Long
        Dim rwLen As Long
        Dim lenKeyword As Long
        Dim lenText As Long
        Dim bWritten As Boolean
    
        For Index = 11& To UBound(m_Captions)
            ' convert keyword to bytes
            lenKeyword = InStr(m_Captions(Index), Chr$(0))
            lenText = Len(m_Captions(Index)) - lenKeyword
            txtData() = StrConv(m_Captions(Index), vbFromUnicode)
            
            ' per PNG specs....
            ' It is recommended that text items less than 1K (1024 bytes)
            ' in size should be output using uncompressed text chunks
            If lenText > 1024& Then
            
                ' IMPORTANT: This portion of the routine is not equipped to write
                ' zero-length text block. That is only handled above where the
                ' .Text length is < 1025... DO NOT modify that IF statement to
                ' allow zero-length chunks to fall thru to this portion of IF
                
                ' zTXt chunk format::
                'Keyword 1-79 bytes (character string)
                'Null separator 1 byte (null character)
                'Compression method 1 byte
                'Compressed text datastream n bytes
                
                ' Note that the compression byte of zero needs to be included too,
                ' but we don't add it to the txtData conversion above cause zero
                ' would be converted to 48 -- Asc("0").
                
                gpLong = lenText * 0.01 + 12& + lenText
                '^^ Text won't always compress smaller; it should, but may not
                ' That is why it is recommended to allow 1024 bytes as uncompressed
                ReDim pngData(1 To gpLong + (lenKeyword + 5&))
                ' ^^ include 4 bytes for chunk name + keyword length + 1 byte compression method
                    
                If zDeflate(VarPtr(pngData(6& + lenKeyword)), gpLong, VarPtr(txtData(lenKeyword)), lenText) = True Then
                    ' ^^ store compression after chunk name, after keyword and after compression method
                    ' ^^ begin compression on 1st byte of the text, not the caption or compression method
                    
                    CopyMemory pngData(1), chnk_zTXt, 4&
                    CopyMemory pngData(5), txtData(0), lenKeyword
                    gpLong = gpLong + lenKeyword + 5&

                    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(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
                    bWritten = True
                Else    ' failed to compress. Which means our buffer was too small
                        ' Therefore we will add it as uncompressed instead of
                        ' making the buffer even bigger
                End If
            End If
            
            If Not bWritten Then 'either len<1025 or compression failed
                ' tXTt chunk format::
                'Keyword 1-79 bytes (character string)
                'Null separator 1 byte (null character)
                'Text string 0 or more bytes (character string)

                gpLong = lenText + lenKeyword + 4&  ' size of chunk
                ReDim pngData(1 To gpLong)
                CopyMemory pngData(1), chnk_tEXt, 4&
                CopyMemory pngData(5), txtData(0), lenKeyword
                
                If Not lenText = 0& Then ' zero-length text; not prohibited by PNG specs
                    CopyMemory pngData(5 + lenKeyword), txtData(lenKeyword), lenText
                End If
                
                If fileNum = 0& Then ' writing to array
                    Index = UBound(Stream) + 1&
                    ReDim Preserve Stream(0 To Index + gpLong + 7&)
                    rwLen = iparseReverseLong(gpLong - 4&)