cpngwriter.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cPNGwriter"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' This class is a partial version of a full-blown PNG creation class.
' It creates a PNG with many options, but not nearly all PNG options avaialble
' and is specifically modified to creating PNGs from pre-multiplied 32bpp DIBs.
' There still may be references to Interlacing. Interlacing options do not
' exist in this class and any such references are results of extracting the
' routines from the full-version PNG creation class.
' Note that GDI+ does not offer any PNG options when creating PNGs, this class
' exposes several options and can be modified to support all PNG options.

' CUSTOM TAILORED FOR PRE-MULTIPLIED 32bpp DIBS. Routines not portable for normal DIBs.

' Required is a version of the zLIB DLL which can be found at www.zlib.net.
' zLIB comes in at least two varieties: C calling convention (_cdecl) and
' VB/PASCAL calling convention (_stdcall). This routine can use either of those
' conventions, but the zLIB file must be named one of the two following,
' not case sensitive, both are original filenames:  zLib.dll or zLib1.dll

' Key highlights:
' 1. PNGs can be created without GDI+ as long as zlib or zlib1 is present
' 2. Using bit reduction algorithms, a 32bpp DIB can be converted to one of the
'       the following:  8 bpp paletted, 24 bpp or 32 bpp PNGs; supporting full alpha
' 3. The PNG compression filtering mechanism in this routine is user-selected.
'       Filters assist in reorganizing byte information to make it compress better
'       Speed vs Size tradeoffs: filter type None is fastest while type Paeth is smallest (generally)
'       See notes in FilterImage routine, set filter in c32bppDIB.PngPropertySet routine
' 4. Over a dozen options available when creating PNGs, see Me.AddProperty
' 5. This class almost always creates smaller PNG files than GDI+ when default filtering is used
' 6. PNGs can be saved to file or saved to an array



' array mapping structures
Private Type SafeArrayBound
    cElements As Long               ' number of array items
    lLbound As Long                 ' the LBound of the array
End Type
Private Type SafeArray
    cDims As Integer                ' numer of dimensions (1) for this UDT
    fFeatures As Integer            ' not used
    cbElements As Long              ' byte size of each element (byte=1,Int=2,Long=4)
    cLocks As Long                  ' not used
    pvData As Long                  ' pointer to memory space containing array
    rgSABound(0 To 1) As SafeArrayBound
End Type

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (ByRef Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
' change to msvbvm50.dll for VB5 projects:
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long

' zLIB calls, needed to compress/decompress png data
' ///////////// ZLIB.DLL REQUIREMENT \\\\\\\\\\\\
' validated via ValidateDLLExists function
Private Declare Function Zcrc32 Lib "zlib.dll" Alias "crc32" (ByVal crc As Long, ByRef buf As Long, ByVal Length As Long) As Long
Private Declare Function Zcompress Lib "zlib.dll" Alias "compress" (ByRef Dest As Long, ByRef destLen As Long, ByRef Source As Long, ByVal sourceLen As Long) As Long
Private Declare Function Zcompress2 Lib "zlib.dll" Alias "compress2" (ByRef Dest As Long, ByRef destLen As Long, ByRef Source As Long, ByVal sourceLen As Long, ByVal Level As Long) As Long

Private Declare Function Zcrc321 Lib "zlib1.dll" Alias "crc32" (ByVal crc As Long, ByRef buf As Any, ByVal Length As Long) As Long
Private Declare Function Zcompress1 Lib "zlib1.dll" Alias "compress" (ByRef Dest As Long, ByRef destLen As Long, ByRef Source As Long, ByVal sourceLen As Long) As Long
Private Declare Function Zcompress21 Lib "zlib1.dll" Alias "compress2" (ByRef Dest As Long, ByRef destLen As Long, ByRef Source As Long, ByVal sourceLen As Long, ByVal Level As Long) As Long
Private Const zlibMaxCompression = 9

Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const INVALID_HANDLE_VALUE = -1

Private Enum eColorTypes    ' internal use only
    clrGrayScale = 0
    clrTrueColor = 2
    clrPalette = 3
    clrGrayAlpha = 4
    clrTrueAlpha = 6
End Enum

'----------------------------------------------------------------------------
' following are optional PNG properties only
Private m_Filter As eFilterMethods
Private m_bKGD As Long          ' default PNG background color if a view opts to render against solid bkg
Private m_Captions() As String  ' see c32bppDIB.ePngProperties
Private m_PNGprops As Long      ' indicates which, if any, m_Captions are used
'----------------------------------------------------------------------------

Private cCfunction As cCDECL        ' class to allow using C calling convention
Private m_ZLIBver As Long           ' which version of zLIB?
Private m_Palette() As Byte         ' PNG palette if image can be palettized
Private m_transPal() As Byte        ' alpha values for PNG palettes as needed
Private m_Uncompressed() As Byte    ' initialized, contains uncompressed DIB bytes in 8,24,32 bit formats
Private m_Stream() As Byte          ' never initialized, overlay to host 32bpp DIB
Private m_Trans As Long             ' flag indicating whether or not transparency is used in DIB
Private m_ColorType As eColorTypes  ' the color type the PNG will be created in

Friend Function SavePNGex(cHost As c32bppDIB, FileName As String, outStream() As Byte) As Boolean

    If cHost.Handle = 0& Then Exit Function
    
    Dim tSA As SafeArray    ' overlay onto our DIB as needed
    Dim bSuccess As Boolean
    Dim fileNum As Integer
    Dim hFile As Long
    Dim bSkipBKGD As Boolean
    
    ' if we don't have Zlib, we can't continue with this class
    If zValidateZLIBversion = False Then Exit Function
    
    If Not FileName = vbNullString Then
        hFile = iparseGetFileHandle(FileName, False)
        If (hFile = INVALID_HANDLE_VALUE) Then Exit Function
    End If
    
    With tSA                ' overlay DIB
        .cbElements = 1
        .cDims = 2
        .pvData = cHost.BitsPointer
        .rgSABound(0).cElements = cHost.Height
        .rgSABound(1).cElements = cHost.scanWidth
    End With
    CopyMemory ByVal VarPtrArray(m_Stream), VarPtr(tSA), 4&
    
    ' optimizations to reduce bit depth and reduce palette data
    
     On Error GoTo ExitRoutine
    ' Can image be palettized (smallest PNG size)?
    m_Trans = -1&
    If PalettizeImage(cHost.Alpha) = False Then
        ' if not, can we reduce to 24bpp from 32bpp?
        OptimizeTrueColor cHost.Alpha
    End If
    '  The above functions converted 32bpp DIB to necessary format for PNG creation
    ' The conversion is in the m_uncompress array. Remove overlay now
    CopyMemory ByVal VarPtrArray(m_Stream), 0&, 4&
    tSA.cDims = 0
    
''   CREATE THE PNG using following rules
''   ------------------------------------
''    Critical chunks (must appear in this order):
''
''               Name  Multiple Ok?  Ordering constraints
''               IHDR    No          Must be first
''               PLTE    No          Before first IDAT (chunk is optional)
''               IDAT    Yes         Multiple IDATs must be consecutive
''               IEND    No          Must be last
''
''    Ancillary chunks (among other ancilliary chunks, order is not dictated):
''
''               Name  Multiple OK?  Ordering constraints relative to Critical chunks
''               cHRM    No          Before PLTE and IDAT
''               gAMA    No          Before PLTE and IDAT
''               iCCP    No          Before PLTE and IDAT
''               sBIT    No          Before PLTE and IDAT
''               sRGB    No          Before PLTE and IDAT
''               bKGD    No          After PLTE; before IDAT
''               hIST    No          After PLTE; before IDAT
''               tRNS    No          After PLTE; before IDAT
''               pHYs    No          Before IDAT
''               sPLT    Yes         Before IDAT
''               tIME    No          None
''               iTXt    Yes         None
''               tEXt    Yes         None
''               zTXt    Yes         None
    
    ' Write the PNG header
    If Write_IHDR(hFile, outStream, cHost, False) = False Then GoTo ExitRoutine
    If Write_tEXt(hFile, outStream, True) = False Then GoTo ExitRoutine ' write the Author & Title if needed
    If Write_PLTE(hFile, outStream, bSkipBKGD) = False Then GoTo ExitRoutine ' write the palette
    If Not bSkipBKGD Then   ' < may be set when bkgd color is not part of palette (Color Type 3 only)
        If Write_bKGD(hFile, outStream) = False Then GoTo ExitRoutine ' write bkgd color
    End If
    If Write_tRNS(hFile, outStream) = False Then GoTo ExitRoutine ' write transparency info
    ' Here we are going to filter & compress the DIB data & then write the IDAT chunk
    If FilterImage(hFile, outStream, cHost, m_Filter) = False Then GoTo ExitRoutine ' write data
    If Write_tIMe(hFile, outStream) = False Then GoTo ExitRoutine ' write last modified timestamp
    If Write_tEXt(hFile, outStream, False) = False Then GoTo ExitRoutine ' write other text (i.e., description, etc)
    If Write_zTXt(hFile, outStream) = True Then ' write any miscellaneous text
        ' Add the IEND termination to the PNG
        bSuccess = Write_IEND(hFile, outStream)   ' write the end flag
    End If

ExitRoutine:
    ' clean up as needed

    If Not tSA.cDims = 0 Then CopyMemory ByVal VarPtrArray(m_Stream), 0&, 4&
    If Not hFile = 0& Then CloseHandle hFile
    
    Erase m_transPal()
    Erase m_Palette()
    Erase m_Uncompressed()
    Set cCfunction = Nothing
    
    If Err Then Err.Clear
    On Error Resume Next
    If bSuccess = False Then
        If hFile = 0& Then Erase outStream() Else iparseDeleteFile FileName
    Else
        SavePNGex = bSuccess
    End If
    If Err Then Err.Clear

End Function

Private Function PropertyIndex(PropertyID As ePngProperties, Optional LargeBlockCaption As String) As Long

    ' Helper function. Returns the m_Captions() array index for the passed PropertyID

    Dim X As Long, CaptionID As Long
    
    If PropertyID = txtLargeBlockText Then
        For CaptionID = 11 To UBound(m_Captions)
            X = InStr(m_Captions(CaptionID), Chr$(0))
            If StrComp(Left$(m_Captions(CaptionID), X - 1&), LargeBlockCaption) = 0& Then Exit For
        Next
        If CaptionID > UBound(m_Captions) Then CaptionID = -1&
    Else
        X = PropertyID
        Do Until X = 1&
            X = X \ 2&
            CaptionID = CaptionID + 1&
        Loop
    End If

    PropertyIndex = CaptionID

End Function

Private Function OptimizeTrueColor(ByVal isAlpha As Boolean) As Boolean

    ' Function attempts to reduce 32bpp DIB to 24bpp DIB.
    ' Reduction to Palette already tried before this routine was called
    ' Reduction can occur when:
    '   1. No transparency is used
    '   2. Only one color is fully transparent (if alpha between 1 & 254 then no reduction)
    
    Dim X As Long, Y As Long
    Dim bAbort As Boolean, tOffset As Long
    Dim palAlpha(0 To 255) As Byte, palCount As Long
    Dim scanWidth As Long, Color As Long
    
    m_Trans = -1&       ' flag indicating no simple transparency. ColorType 6 implies transparency
    If isAlpha Then
        ' we will test if only full transparency is used, and only one color uses transparency.
        ' We don't need to determine which color is transparent, because with pre-multiplied
        ' DIBs, the color is always black: 0,0,0. But if another color is transparent, can't reduce
        
        m_ColorType = clrTrueAlpha  ' default color type for this DIB
        For Y = 0& To UBound(m_Stream, 2)
            For X = 3& To UBound(m_Stream, 1) Step 4&
                ' look at alpha values, if any are semi-transparent, abort
                If m_Stream(X, Y) = 0 Then ' full transparency
                    ' If color is not black, we abort
                    If Not (m_Stream(X - 3, Y) = 0) Then
                        bAbort = True: Exit For
                    ElseIf Not (m_Stream(X - 2, Y) = 0) Then
                        bAbort = True: Exit For
                    ElseIf Not (m_Stream(X - 1, Y) = 0) Then
                        bAbort = True: Exit For
                    End If
                
                ElseIf Not m_Stream(X, Y) = 255 Then   ' partial transparency, abort
                    bAbort = True: Exit For
                End If
            Next
            If bAbort Then Exit For
        Next
        If Not bAbort Then ' reduction to 24bpp can be done?
            ' now here's the catch. Black is always transparent in premultiplied DIBs, but if
            ' non-transparent black is used anywhere else in the image, then we can't leave
            ' black as the transparent color; we'll need to change it. This routine will run
            ' quickly. We will not make the effort to check every possible color in the 16 million
            ' color range, rather, we will be looking at just 1024 colors: 256 Reds, 256 Greens,
            ' & 256 Blues. If we find one we can use, bingo, else write as 32bpp
            For Color = 0& To 2&  ' Color = B, G, R
            
                tOffset = 3& - Color ' location of the alpha byte relative to "Color"
                palCount = 0&       ' number of "Color" shades used; from 1 to 256
                
                For Y = 0& To UBound(m_Stream, 2)
                    For X = Color To UBound(m_Stream, 1) Step 4&