cpngwriter.cls

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

                        If Not m_Stream(X + tOffset, Y) = 0 Then    ' is this our transparent color?
                            If palAlpha(m_Stream(X, Y)) = 0 Then    ' no, but has it been counted?
                                palCount = palCount + 1&            ' up the count & abort if we maxed out
                                If palCount = 256& Then
                                    bAbort = True
                                    Exit For
                                End If
                                palAlpha(m_Stream(X, Y)) = 1        ' flag it
                            End If
                        End If
                    Next
                    
                    If bAbort Then Exit For ' all 256 shades of "Color" used
                    
                Next
                
                If palCount < 256& Then ' did we find a color we can use?
                    For X = 0& To 255&  ' lets find out which it is
                        If palAlpha(X) = 0 Then
                            ' since the X-shade of the R, G, or B isn't used in the image,
                            ' we can safely state that RGB(X,X,X) is also not in the image
                            m_Trans = X Or X * &H100& Or X * &H10000
                            Exit For
                        End If
                    Next
                    m_ColorType = clrTrueColor  ' reduce to 24bpp vs 32bpp
                    Exit For
                End If
                
                Erase palAlpha()    ' reset to zeros
                bAbort = False      ' reset
                
            Next
        End If
    Else
        m_ColorType = clrTrueColor      ' no transparency, reduction to 24bpp
    End If
    
    ' Use separate loops vs adding an IF statement for every pixel to test for color type
    If m_ColorType = clrTrueAlpha Then  ' 32bpp (ColorType 6)
        scanWidth = UBound(m_Stream, 1) + 1&
        ReDim m_Uncompressed(0 To scanWidth * (UBound(m_Stream, 2) + 1&) - 1&)
        For Y = 0& To UBound(m_Stream, 2)
            tOffset = Y * scanWidth
            For X = 0& To UBound(m_Stream, 1) Step 4&
                ' simultaneously remove pre-multiplication
                Select Case m_Stream(X + 3&, Y)
                Case 255
                    m_Uncompressed(tOffset) = m_Stream(X + 2&, Y)
                    m_Uncompressed(tOffset + 1&) = m_Stream(X + 1&, Y)
                    m_Uncompressed(tOffset + 2&) = m_Stream(X, Y)
                    m_Uncompressed(tOffset + 3&) = 255
                Case 0 ' do nothing
                Case Else
                    Color = m_Stream(X + 3&, Y)
                    m_Uncompressed(tOffset) = (255& * m_Stream(X + 2&, Y) \ Color)
                    m_Uncompressed(tOffset + 1&) = (255& * m_Stream(X + 1&, Y) \ Color)
                    m_Uncompressed(tOffset + 2&) = (255& * m_Stream(X, Y) \ Color)
                    m_Uncompressed(tOffset + 3&) = Color
                End Select
                tOffset = tOffset + 4&
            Next
        Next
    Else            ' 24bpp (Color Type 2) with or without simple transparency
        scanWidth = iparseByteAlignOnWord(24, UBound(m_Stream, 1) \ 4 + 1&)
        ' convert BGR to RGB, the Filter function expects 1D arrays
        ReDim m_Uncompressed(0 To scanWidth * (UBound(m_Stream, 2) + 1&) - 1&)
        For Y = 0& To UBound(m_Stream, 2)
            tOffset = Y * scanWidth
            For X = 0& To UBound(m_Stream, 1) Step 4&
                ' simultaneously remove pre-multiplication. Don't carry over any alpha values
                Select Case m_Stream(X + 3&, Y)
                Case 255
                    m_Uncompressed(tOffset) = m_Stream(X + 2&, Y)
                    m_Uncompressed(tOffset + 1&) = m_Stream(X + 1&, Y)
                    m_Uncompressed(tOffset + 2&) = m_Stream(X, Y)
                Case 0 ' uses simple transparency (1 color is transparent)
                    CopyMemory m_Uncompressed(tOffset), m_Trans, 3&
                Case Else
                    Color = m_Stream(X + 3&, Y)
                    m_Uncompressed(tOffset) = (255& * m_Stream(X + 2&, Y) \ Color)
                    m_Uncompressed(tOffset + 1&) = (255& * m_Stream(X + 1&, Y) \ Color)
                    m_Uncompressed(tOffset + 2&) = (255& * m_Stream(X, Y) \ Color)
                End Select
                tOffset = tOffset + 3&
            Next
        Next
    End If
End Function

Private Function PalettizeImage(isAlpha As Boolean) As Boolean

    ' Function determines if image can be palettized vs 24/32 bpp true color
    ' Once determined it can be paletted, it will optimize to include the following:
    ' 1. Convert to PNG grayscale palette if possible, saves at least 768 bytes vs color palette
    ' 2. Rearrange palette to reduce alpha/palette entries, saves up to 200+ bytes if alpha is used
    ' 3. Converts per-color grayscale to a modified color palette, reducing size at least 50%
    ' This modified version does not reduce to 1,2,or 4 bits per pixel
    '   -- Any paletted image is 256 colors, but only needed palette entries are cached in PNG
    
    Dim X As Long, Y As Long, scanWidth As Long
    Dim palCount As Long, Index As Long
    Dim Color As Long, newColor As Boolean
    Dim palXRef() As Byte, palAlpha() As Byte
    Dim tSortIndex() As Long, tPalette() As Long
    
    On Error GoTo ExitRoutine
    
    ' count unique colors (maximum of 256 if we are to palettize)
    ' Note that alphas are included in the tSortIndex. This is because any color
    ' using more than one alpha value would require separate palette entries:
    ' Example: Red @ Alpha 255 & Red @ Alpha 128 requires two palette entries
    ReDim m_transPal(1 To 256)          ' array to hold alpha values only
    ReDim tSortIndex(1 To 256)          ' sort indexes
    ReDim tPalette(1 To 256) As Long    ' palette
    For Y = 0& To UBound(m_Stream, 2)
        For X = 0& To UBound(m_Stream, 1) Step 4&
        
            CopyMemory Color, m_Stream(X, Y), 4&
            Index = FindColor(tSortIndex, Color, palCount, newColor)   ' use binary search routine
            If newColor = True Then
                If palCount = 256& Then Exit Function       ' exceeded palette entries limit
                palCount = palCount + 1&                    ' increment entry count & shift palette to maintain asc sort
                If Index < palCount Then
                    CopyMemory tSortIndex(Index + 1&), tSortIndex(Index), (palCount - Index) * 4&
                    CopyMemory tPalette(Index + 1&), tPalette(Index), (palCount - Index) * 4&
                End If
                tSortIndex(Index) = Color                    ' add new color to the palette
                CopyMemory tPalette(Index), Color, 3&
            End If
        
        Next
    Next
    
    ' if we got here, then image can be palettized, but to which of the following?
    ' 1. Palette - no transparency? like non-transparent GIFs (isAlpha=False)
    ' 2. Palette - simple transparency? like transparent GIFs (grayscale handled differently in PNGs)
    ' 3. Palette - per-color index transparency?
    
    Y = 0&
    If isAlpha Then
        ' separate alpha from color and count how many non-opaque alpha values
        For X = 1& To palCount
            If (tSortIndex(X) And &H7FFFFFFF) = tSortIndex(X) Then ' high bit not set
                m_transPal(X) = tSortIndex(X) \ &H1000000
            Else                                                 ' high bit is set
                m_transPal(X) = ((tSortIndex(X) And &H7FFFFFFF) \ &H1000000) Or &H80
            End If
            If Not m_transPal(X) = 255 Then
                Y = Y + 1&   ' count different levels of transparency
                Index = X    ' track last palette entry with alpha value <> 255
            End If
        Next
    Else
        FillMemory m_transPal(1), 256&, 255 ' all alphas are opaque
    End If
    
    Select Case Y
    Case 0&
    ' 1. Palette - no transparency? like non-transparent GIFs (isAlpha=False)
        m_Trans = -1& ' no transparency
    Case 1&
    ' 2. Palette - simple transparency? like transparent GIFs
        m_Trans = Index ' flag & may be changed later in this routine
    Case Else
    ' 3. Palette - per-color transparency?
        m_Trans = 0& ' > -1 means we have transparency at some level
        ' alphas are kept in the m_transPal() array
    End Select
    
'     Now for the last optimization attempt: check for grayscale but only for non per-color
'     alpha images. Why restrict grayscale to non per-color alpha when PNG can support grayscale
'     per-color alpha? Here's why: per-color grayscale alpha is ColorType 4. ColorType 4
'     always requires 16 bits per pixel (bpp), regardless of grayscale bit depth, but
'     ColorType 3 requires 8 bpp (max) + 768 palette bytes (max) + 256 bytes (max) for alpha info:
'       ColorType 4, 256x256 image: 256*256*2=131072 bytes for color information (grayscale has no palette in PNGs)
'       ColorType 3 (8bpp), 256x256 image: 256*256*1+768+256=66560 bytes for color information
'           note: ColorType 4 is always 16bpp, but ColorType 3 can be 1,2,4,8 bpp
'           and palette/alpha arrays can be reduced too
    
    m_ColorType = clrPalette    ' Color Type 3 (color palette)
    If Not m_Trans = 0& Then
        ' check each palette entry to see if grayscale or not. When not, abort loop
        For Index = 1& To palCount
            If Not (tPalette(Index) And &HFF) = ((tPalette(Index) \ &H100&) And &HFF) Then ' compare B to G
                Exit For
            ElseIf Not (tPalette(Index) And &HFF) = ((tPalette(Index) \ &H10000) And &HFF) Then ' compare B to R
                Exit For
            End If
        Next
        
        If Index > palCount Then    ' need to tweak transparency possibly
        
            m_ColorType = clrGrayScale ' Color Type 0
            
            If isAlpha = True Then
                ' we only got here because just 1 color was transparent & with a pre-multiplied DIB
                ' that color is always black. But if non-transparent black was used elsewhere in the
                ' grayscale then we need to change the transparency. Non-transparent black is very
                ' common in grayscales
                ReDim palXRef(1 To 256) ' track which grayscales are used
                For X = 1& To palCount
                    If tPalette(X) = 0& Then             ' this is black
                        If Not m_transPal(X) = 0& Then   ' and not our transparent black
                            palXRef(1) = 1     ' mark black as used
                        End If
                    Else
                        palXRef(Index + 1&) = 1 ' non-black, mark as used
                    End If
                Next
                If palXRef(1) = 1 Then
                    ' non-transparent black is used in the grayscale, so we must change our
                    ' tranparent black - Locate a grayscale not in use
                    For Index = 2& To palCount
                        If palXRef(Index) = 0 Then
                            ' bingo, we'll use this one
                            m_Trans = Index - 1&
                            Exit For
                        End If
                    Next
                Else    ' black was not in the image, we can use black as transparency
                    m_Trans = 0&
                End If
                Erase palXRef
            End If
        End If
    End If
    
    scanWidth = UBound(m_Stream, 1) \ 4& + 1&         ' width of image
    X = (UBound(m_Stream, 2) + 1) * scanWidth - 1&   ' calculate size of total image bytes
    ReDim m_Uncompressed(0 To X)    ' the Filter function expects 1D arrays
    
    If m_ColorType = clrGrayScale Then
        ' grayscale is easy enough, transfer 32bpp info to 8bpp info
        ' Remember, PNG grayscale color types do not use palettes.
        ' Grayscale palettes are PNG decoders responsibility
        Erase m_transPal()
        For Y = 0& To UBound(m_Stream, 2)
            Index = Y * scanWidth
            For X = 0& To UBound(m_Stream, 1) Step 4&
                If m_Stream(X + 3&, Y) = 0& Then     ' transparency index needed
                    m_Uncompressed(Index) = m_Trans ' use modified transparency index as necessary
                Else
                    m_Uncompressed(Index) = m_Stream(X, Y)  ' use grayscale index
                End If
                Index = Index + 1&
            Next
        Next
        
    Else
        ' for color palettes, we want to re-order entries when per-color alpha is used.
        ' Why the hassle? Shrink PNG a bit more. When color palettes have transparency,
        ' you must have a 1 byte Alpha value for each palette entry. But, that 1 byte
        ' alpha value, when = 255, is optional and implied. Therefore, if we move all
        ' palette entries with transparency to top of array, then all those 255s at the
        ' bottom of the array don't need to be cached in the PNG; not being there, PNG
        ' decoders must assume value is 255. We can save anywhere up to 200+ bytes
        ' depending on the image.
        ReDim palXRef(0 To 1, 0 To palCount - 1)
        
        If m_Trans = -1& Then   ' no transparencies and not grayscale
            Erase m_transPal
            For X = 0& To palCount - 1& ' all entries are opaque, no cross-referencing needed
                palXRef(0, X) = X
                palXRef(1, X) = X
            Next
        Else                    ' per-color alpha being used
            ' since we are re-ordering, we also need to build a cross-reference so
            ' we can reference palette locations, old to new and vice versa
            Y = 0&: X = palCount - 1&  ' starting points for top & bottom of array
            For Index = 0& To palCount - 1&
                If m_transPal(Index + 1&) = 255 Then
                    palXRef(1, X) = Index ' keep full opaque entries at bottom of array
                    palXRef(0, Index) = X ' double link reference
                    X = X - 1&
                Else
                    palXRef(0, Index) = Y ' move non-opaque entries near top of array
                    palXRef(1, Y) = Index ' double link reference
                    Y = Y + 1&
                End If
            Next
        End If
        
        ' now we build our 8 bpp paletted image, referencing the re-sorted palette entires
        For Y = 0& To UBound(m_Stream, 2)
            Index = Y * scanWidth
            For X = 0& To UBound(m_Stream, 1) Step 4&
                ' get 32bit color from DIB
                CopyMemory Color, m_Stream(X, Y), 4&
                ' locate it in our temp palette using binary search algorithm
                Color = FindColor(tSortIndex, Color, palCount, False)
                ' now cache its re-sorted reference