cpngwriter.cls

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

                m_Uncompressed(Index) = palXRef(0, Color - 1&)
                Index = Index + 1&
            Next
        Next
        
        ' good, now we need to build the palette the PNG will use,
        ' but we will be using 3 byte values, not 4 byte values & colors need to be RGB vs BGR
        ReDim m_Palette(1 To palCount * 3& + 4&) ' extra 4 bytes are used during Write_PLTE
        For X = 1& To palCount
            ' calculate new index for this palette entry
            Index = palXRef(0, X - 1&) * 3& + 5&   ' offset that extra 4 bytes too
            ' simultaneously remove pre-multiplication
            Select Case m_transPal(X)
            Case 255    ' full opaque
                m_Palette(Index) = (tPalette(X) \ &H10000) And &HFF&
                m_Palette(Index + 1&) = (tPalette(X) \ &H100&) And &HFF&
                m_Palette(Index + 2&) = tPalette(X) And &HFF&
            Case 0: ' do nothing, color is always 0,0,0
            Case Else
                m_Palette(Index) = (((tPalette(X) \ &H10000) And &HFF&) * m_transPal(X) \ 255)
                m_Palette(Index + 1&) = (((tPalette(X) \ &H100&) And &HFF&) * m_transPal(X) \ 255)
                m_Palette(Index + 2&) = ((tPalette(X) And &HFF&) * m_transPal(X) \ 255)
            End Select
        Next
        Erase tPalette()
        
        If Not m_Trans = -1& Then
            ' now we are going to double check how many non-opaque palette entries we have
            For X = 0& To palCount - 1&
                If m_transPal(palXRef(1, X) + 1&) = 255 Then
                    palCount = X    ' we saved 256-X bytes at least
                    Exit For
                End If
            Next
            ReDim palAlpha(1 To palCount + 4&)   ' extra 4 bytes used in Write_tRNS
            ' rewrite the m_transPal array, only caching non-opaque palette entries
            For X = 0& To palCount - 1&
                palAlpha(X + 5&) = m_transPal(palXRef(1, X) + 1&)
            Next
            m_transPal = palAlpha
        
        End If
    End If
    
    PalettizeImage = True

ExitRoutine:
End Function

Private Function FindColor(ByRef PaletteItems() As Long, ByVal Color As Long, ByVal Count As Long, ByRef isNew As Boolean) As Long

    ' MODIFIED BINARY SEARCH ALGORITHM -- Divide and conquer.
    ' Binary search algorithms are about the fastest on the planet, but
    ' its biggest disadvantage is that the array must already be sorted.
    ' Ex: binary search can find a value among 1 million values in less than 20 iterations
    
    ' [in] PaletteItems(). Long Array to search within. Array must be 1-bound
    ' [in] Color. A value to search for. Order is always ascending
    ' [in] Count. Number of items in PaletteItems() to compare against
    ' [out] isNew. If Color not found, isNew is True else False
    ' [out] Return value: The Index where Color was found or where the new Color should be inserted

    Dim UB As Long, LB As Long
    Dim newIndex As Long
    
    If Count = 0& Then
        FindColor = 1&
        isNew = True
        Exit Function
    End If
    
    UB = Count
    LB = 1&
    
    Do Until LB > UB
        newIndex = LB + ((UB - LB) \ 2&)
        If PaletteItems(newIndex) = Color Then
            Exit Do
        ElseIf PaletteItems(newIndex) > Color Then ' new color is lower in sort order
            UB = newIndex - 1&
        Else ' new color is higher in sort order
            LB = newIndex + 1&
        End If
    Loop

    If LB > UB Then  ' color was not found
            
        If Color > PaletteItems(newIndex) Then newIndex = newIndex + 1&
        isNew = True
        
    Else
        isNew = False
    End If
    
    FindColor = newIndex

End Function


Private Function ByteAlignOnByte(ByVal totalWidth As Long, ByVal btsPerPixel As Byte) As Long
' // LaVolpe, Dec 1 thru 10
    ' returns number of bytes required to display n pixels at p color depth (byte aligned)
    ByteAlignOnByte = (totalWidth * btsPerPixel + 7&) \ 8&
End Function

Private Function Write_IHDR(fileNum As Long, Stream() As Byte, Host As c32bppDIB, isInterlaced As Boolean) As Boolean

    Const png_Signature1 As Long = 1196314761
    Const png_Signature2 As Long = 169478669
    Const chnk_IHDR As Long = &H52444849 'Image header
    
    On Error GoTo eh
    Dim pngData(0 To 16) As Byte ' 13 byte header + 4 byte chunk name
    Dim gpLong As Long           ' general purpose variable
    Dim rwLen As Long
    
    ' build header
    CopyMemory pngData(0), chnk_IHDR, 4&    ' chunk name
    gpLong = iparseReverseLong(Host.Width)   ' png width
    CopyMemory pngData(4), gpLong, 4&
    gpLong = iparseReverseLong(Host.Height)  ' png height
    CopyMemory pngData(8), gpLong, 4&
    
    ' bit depth, 16bit (PNG 16 bytes per R,G,B element or 48 bytes per pixel)
    ' not supported via this class
    pngData(12) = 8 ' only 1,2,4,48 bpp are different, 8,24,32 bpp is 8
    
    pngData(13) = m_ColorType
    ' pngData(14) & (15) will always be zero (compression/filter methods)
    ' next byte is 1 if interlaced
    pngData(16) = Abs(isInterlaced)

    If fileNum = 0& Then ' writing to array vs file
        ReDim Stream(0 To 32) ' png signature, header len, header, crc value (33 bytes)
        CopyMemory Stream(0), png_Signature1, 4&
        CopyMemory Stream(4), png_Signature2, 4&
        gpLong = iparseReverseLong(13&) ' len of header
        CopyMemory Stream(8), gpLong, 4&
        CopyMemory Stream(12), pngData(0), 17&
        gpLong = zCreateCRC(VarPtr(pngData(0)), 17&)
        CopyMemory Stream(29), gpLong, 4&
        Write_IHDR = True
    Else
    
        WriteFile fileNum, png_Signature1, 4&, rwLen, ByVal 0&
        If rwLen = 4& Then
            WriteFile fileNum, png_Signature2, rwLen, rwLen, ByVal 0&
            If rwLen = 4& Then
                WriteFile fileNum, iparseReverseLong(13&), rwLen, rwLen, ByVal 0&
                If rwLen = 4& Then
                    WriteFile fileNum, pngData(0), 17&, rwLen, ByVal 0&
                    If rwLen = 17& Then
                        WriteFile fileNum, zCreateCRC(VarPtr(pngData(0)), rwLen), 4&, rwLen, ByVal 0&
                        Write_IHDR = (rwLen = 4&)
                    End If
                End If
            End If
        End If
    End If
eh:
    If Err Then Err.Clear
End Function


Private Function Write_PLTE(fileNum As Long, Stream() As Byte, Invalid_bKGD As Boolean) As Boolean

    ' Note: the palette is preprocessed before it arrives here: BGR>RGB
    On Error GoTo eh
    
    If m_ColorType = clrPalette Then ' paletted images only
    
        Const chnk_PLTE As Long = &H45544C50 'Palette
        
        Dim gpLong As Long          ' general purpose variable
        Dim Index As Long
        Dim rwLen As Long
        
        ' when paletted, the bKGD chunk comes after the palette, but for palettes the
        ' bkgd chunk must be one of the palette entries, therefore, we will attempt to
        ' find the color in the palette, add it to the palette if possible, or skip
        ' the optional chunk if color is not in the palette
        If (m_PNGprops And ePngProperties.colorDefaultBkg) = ePngProperties.colorDefaultBkg Then
            Dim bkg(0 To 2) As Byte
            CopyMemory bkg(0), m_bKGD, 3&
            For Index = 5& To UBound(m_Palette) Step 3&
                If bkg(0) = m_Palette(Index) Then
                    If bkg(1) = m_Palette(Index + 1&) Then
                        If bkg(2) = m_Palette(Index + 2&) Then Exit For
                    End If
                End If
            Next
            If Index < UBound(m_Palette) Then   ' found it, ref the index
                m_bKGD = (Index - 5&) \ 3&
            ElseIf UBound(m_Palette) < 772& Then ' we can add it, let's do that
                ' ^^ 772 is 256*3+4
                ReDim Preserve m_Palette(1 To UBound(m_Palette) + 3&)
                m_bKGD = (UBound(m_Palette) - 5&) \ 3&
                CopyMemory m_Palette(UBound(m_Palette) - 2&), bkg(0), 3&
            Else
                Invalid_bKGD = True ' do not write the bkgd chunk
            End If
        End If
            
        CopyMemory m_Palette(1), chnk_PLTE, 4&
        gpLong = UBound(m_Palette)
        
        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&                 ' size of chunk
            CopyMemory Stream(Index + 4&), m_Palette(1), gpLong ' palette
            rwLen = zCreateCRC(VarPtr(m_Palette(1)), gpLong)
            CopyMemory Stream(Index + gpLong + 4&), rwLen, 4&   ' crc
            Write_PLTE = True
        Else
            WriteFile fileNum, iparseReverseLong(gpLong - 4&), 4&, rwLen, ByVal 0&
            If rwLen = 4& Then
                WriteFile fileNum, m_Palette(1), gpLong, rwLen, ByVal 0&
                If rwLen = gpLong Then
                    WriteFile fileNum, zCreateCRC(VarPtr(m_Palette(1)), gpLong), 4&, rwLen, ByVal 0&
                    Write_PLTE = (rwLen = 4&)
                End If
            End If
        End If
        Erase m_Palette()   ' no longer needed
    Else
        Write_PLTE = True
    End If
eh:
    If Err Then Err.Clear

End Function

Private Function Write_tEXt(fileNum As Long, Stream() As Byte, bTitleAuthorOnly As Boolean) As Boolean

    ' Function writes uncompressed standard Keywords & text to the PNG
    
    ' Note. Per PNG specs, some text should be written near top of the file while others
    ' should be written near the end. There is no requirement for text to appear in
    ' any specific location. The logic for writing some near the top is for search
    ' engines only. It would be faster to find that text if nearer the top.
    ' Therefore, this routine is called twice, once near the top of the PNG and
    ' and again just before the IEND chunk is written
    
    Const chnk_tEXt As Long = &H74584574 'Text - uncompressed
    
    On Error GoTo ExitRoutine
    
    Dim pngData() As Byte   ' data to be written to PNG file
    Dim txtData() As Byte
    Dim gpLong As Long
    Dim lenKeyword As Long
    Dim lenText As Long
    
    Dim Index As Long
    Dim CaptionID As Long
    Dim tProps As Long
    Dim lastCaption As Long
    Dim keyWord As String
    Dim rwLen As Long
    
    If bTitleAuthorOnly Then    ' called after writing IHDR
        CaptionID = ePngProperties.txtTitle
        lastCaption = ePngProperties.txtDescription
    Else                        ' called before writing IEND
        CaptionID = ePngProperties.txtDescription
        lastCaption = ePngProperties.txtLargeBlockText
    End If
    tProps = m_PNGprops
    Do Until CaptionID = lastCaption
        If (tProps And CaptionID) = CaptionID Then
            tProps = tProps And Not CaptionID
            Select Case CaptionID
            Case txtTitle: Index = 0
                keyWord = "Title" & Chr$(0)
            Case txtAuthor: Index = 1&
                keyWord = "Author" & Chr$(0)
            Case txtComment: Index = 9&
                keyWord = "Comment" & Chr$(0)
            Case txtCopyright: Index = 3&
                keyWord = "Copyright" & Chr$(0)
            Case txtCreationTime: Index = 4&
                keyWord = "Creation Time" & Chr$(0)
            Case txtDescription: Index = 2&
                keyWord = "Description" & Chr$(0)
            Case txtDisclaimer: Index = 6&
                keyWord = "Disclaimer" & Chr$(0)
            Case txtSoftware: Index = 5&
                keyWord = "Software" & Chr$(0)
            Case txtSource: Index = 8&
                keyWord = "Source" & Chr$(0)