cpngparser.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 = "cPNGparser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
' PNG Parser & PNG to 32bpp converter
' The PNG will be parsed using the following resources if they are available
' and in the following order.
' 1) If GDI+ is available, the entire PNG will be processed via GDI+
' 2) If zLIB.DLL or zLIB1.DLL is available, the PNG will be decompressed via zLIB
' 3) If none of the above, the PNG will be decompressed with pure VB

' No APIs are declared public. This is to prevent possibly, differently
' declared APIs, or different versions of the same API, from conflciting
' with any APIs you declared in your project. Same rule for UDTs.
' Note: I did take some liberties in several API declarations throughout

Private Declare Function ReadFile Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, ByRef lpNumberOfBytesRead As Long, ByRef lpOverlapped As Any) As Long
Private Declare Function SetFilePointer Lib "kernel32.dll" (ByVal hFile As Long, ByVal lDistanceToMove As Long, ByRef lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function GetFileSize Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpFileSizeHigh As Long) As Long
Private Const FILE_CURRENT As Long = 1

' Used to create a return DIB section
Private Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (ByRef Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal hDC As Long, ByRef pBitmapInfo As Any, ByVal un As Long, ByRef lplpVoid As Long, ByVal Handle As Long, ByVal dw As Long) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Type SafeArrayBound
    cElements As Long
    lLbound As Long
End Type
Private Type SafeArray
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    rgSABound(0 To 1) As SafeArrayBound
End Type
Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As Long
End Type


' Following are used only if PNG file is being manually decompressed with pure VB
Private Type CodesType
    Length() As Long
    code() As Long
End Type
Private OutPos As Long
Private Inpos As Long
Private ByteBuff As Long
Private BitNum As Long
Private BitMask() As Long
Private Pow2() As Long

Private LCodes As CodesType
Private DCodes As CodesType
Private LitLen As CodesType
Private Dist As CodesType
Private TempLit As CodesType
Private TempDist As CodesType
Private LenOrder() As Long

' Following are used if PNG will be decompressed by zLIB
' -- older version of zLIB (version 1.1.? or earlier)
Private Declare Function Zuncompress Lib "zlib.dll" Alias "uncompress" (ByRef Dest As Any, ByRef destLen As Long, ByRef Source As Any, ByVal sourceLen As Long) As Long
Private Declare Function Zcrc32 Lib "zlib.dll" Alias "crc32" (ByVal crc As Long, ByRef buf As Any, ByVal Length As Long) As Long
' -- latest version of zLIB (version 1.2.3)
Private Declare Function Zuncompress1 Lib "zlib1.dll" Alias "uncompress" (ByRef Dest As Any, ByRef destLen As Long, ByRef Source As Any, ByVal sourceLen 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


' following are the actual PNG image properties, exposed via class properties
' (**)Not all are translated until called from the appropriate class property
Private m_Width As Long                 ' image width
Private m_Height As Long                ' image height
Private m_BitDepth As Byte              ' image bit depth/count: 1,2,4,8,16
Private m_ColorType As Byte             ' image color type: 0,2,3,4,6
Private m_Interlacing As Byte           ' interlaced: 0,1
Private m_Palette() As Byte             ' image palette information
Private m_TransSimple() As Byte         ' image simple transparency information
Private m_TransColor As Long  ' translated simple transparency color (BGR or index value)

' matrix/lookup tables
Private pow2x8() As Long                ' a look up table for bit shifting (1,2,4 bit pixels)
Private m_MatrixDat() As Byte           ' see eMatrixType below & InitializeMatrix routine

Private Enum eColorTypes ' internal use only
    clrGrayScale = 0
    clrTrueColor = 2
    clrPalette = 3
    clrGrayAlpha = 4
    clrTrueAlpha = 6
End Enum
Private Enum eMatrixType ' internal use only
    MatrixRow = 0           ' row where each pass starts within interlace matrix
    MatrixCol = 1           ' column where each pass starts within interlace matrix
    MatrixRowAdd = 2        ' gaps between each row withiin each pass
    MatrixColAdd = 3        ' gaps between each column within each pass
    MatrixPixelHeight = 4   ' height of each pixel in a scanline (progressive display)
    MatrixPixelWidth = 5    ' width of each pixel in a scanline (progressive display)
End Enum

' PNG chunk names & their numerical equivalent (those used in this class)
' Per png specs; using alpha chars is a no-no should system not support those characters
' http://www.libpng.org/pub/png/spec/1.1/PNG-Chunks.html
Private Const chnk_IHDR As Long = &H52444849 'Image header
Private Const chnk_IDAT As Long = &H54414449 'Image data
Private Const chnk_IEND As Long = &H444E4549 'End of Image
Private Const chnk_PLTE As Long = &H45544C50 'Palette
Private Const chnk_tRNS As Long = &H534E5274 'Simple Transparency

Private Const png_Signature1 As Long = 1196314761
Private Const png_Signature2 As Long = 169478669
'^^ Complete signature is 8 bytes: 137 80 78 71 13 10 26 10

Private inStream() As Byte      ' overlay only for vbDecompress routine; nevery initialized
Private cCfunction As cCDECL    ' allows calling DLL's that export _CDECL functions, not _StdCall functions
Private m_ZLIBver As Long       ' indicates which zLIB version was found on system: 1=older, 2=newer, 0=dll not found

Private pngStream() As Byte ' overlay of bytes when using LoadStream, else individual chunk bytes when using LoadFile
Private cHost As c32bppDIB  ' owner of 32bpp destination image

Public Function LoadStream(Stream() As Byte, dibClass As c32bppDIB, _
            Optional ByVal streamOffset As Long = 0, _
            Optional ByVal streamLength As Long = 0, _
            Optional GlobalToken As Long) As Boolean

    ' PURPOSE: Determine if passed array is a PNG & if it is, then convert it to
    ' a 32bpp owned by dibClass
    
    ' Parameters.
    ' Stream() :: a byte array containing the possible PNG image
    ' dibClass :: an initialized c32bppDIB class
    ' streamOffset :: array position for 1st byte in the stream
    ' streamLength :: size of stream that contains the image
    '   - If zero, then size is UBound(inStream)-streamOffset+1

    ' IMPORTANT: the array offset & length are not checked in this class.
    '   They were checked before this class was called. If this class is to
    '   be pulled out and put in another project, ensure you include the
    '   validation shown in c32bppDIB.LoadPicture_Stream
    
    Dim tSA As SafeArray
    With tSA    ' prepare to overlay. Overlay prevents VB copying bytes into another array for processing
        .cbElements = 1     ' as byte array
        .cDims = 1          ' 1 dimensional
        .pvData = VarPtr(Stream(streamOffset))
        .rgSABound(0).cElements = streamLength
    End With
    CopyMemory ByVal VarPtrArray(pngStream), VarPtr(tSA), 4& ' establish overlay

    Set cHost = dibClass
    LoadStream = LoadPNG(0&, vbNullString, streamLength, GlobalToken)
    CopyMemory ByVal VarPtrArray(pngStream), 0&, 4& ' remove overlay
    Set cHost = Nothing
    
End Function

Public Function LoadFile(ByVal FileHandle As Long, ByVal FileName As String, dibClass As c32bppDIB, Optional GlobalToken As Long) As Boolean

    ' PURPOSE: Determine if passed file is a PNG & if it is, then convert it to
    ' a 32bpp owned by dibClass
    
    ' Parameters.
    ' FileName :: full path and file
    ' dibClass :: an initialized c32bppDIB class

    ' IMPORTANT: the existance and validity of the filename is not checked here.
    '   They were checked before this class was called. If this class is to
    '   be pulled out and put in another project, ensure you include the
    '   validation shown in c32bppDIB.LoadPicture_File

    Set cHost = dibClass
    LoadFile = LoadPNG(FileHandle, FileName, 0&, GlobalToken)
    Set cHost = Nothing

End Function

Private Function LoadPNG(FileHandle As Long, FileName As String, streamLength As Long, Optional GlobalToken As Long) As Boolean

    ' PURPOSE: Determine if passed file is a PNG & if it is, then convert it to
    ' a 32bpp owned by dibClass
    
    ' Parameters.
    ' FileName :: full path and file
    ' dibClass :: an initialized c32bppDIB class

    Dim ptrLoc As Long          ' used to ensure parsing doesn't go past EOF of corrupted file
    Dim ptrArray As Long
    Dim FileNumber As Long      ' the file handle
    Dim gpLong As Long          ' general purpose long value
    Dim readRtn As Long
    Dim lenIDAT As Long         ' running total of the png data size (compressed)
    
    Dim ChunkName As Long       ' name of the chunk
    Dim ChunkLen As Long        ' length of the chunk
    
    Dim RawPNGdata() As Byte    ' uncompressed png data
    Dim IDATdata() As Byte      ' compressed png data
    
    Dim uncmprssSize As Long    ' calculated size of uncompressed PNG data
    Dim lError As Long
    
    Dim bCRCchecks As Boolean   ' whether or not to use CRC checks on chunks
    Dim crc32value As Long      ' if CRC checks applied, the the CRC value
    
    Dim cGDIp As cGDIPlus
    
    ' reset class' only key property
    m_TransColor = -1&
    
    ' attempt to open the file with read access
    If FileName = vbNullString Then
    
        ptrLoc = 7&              ' counter to prevent overflow of array
        ptrArray = 8&            ' current position in passed array
        If IsPNG() = False Then
            Exit Function
        Else
            LoadPNG = True ' & process it using GDI+ if available
            Set cGDIp = New cGDIPlus
            If cGDIp.GDIplusLoadPNG(FileName, pngStream(), cHost, GlobalToken) = True Then
                m_Width = cHost.Width
                m_Height = cHost.Height
                Exit Function
            End If
            Set cGDIp = Nothing
        End If
        
    Else
        On Error Resume Next
        FileNumber = FileHandle
        SetFilePointer FileNumber, 0&, 0&, 0&
        
        ' validate we are looking at a png file
        streamLength = GetFileSize(FileHandle, 0&)
        If streamLength > 56& Then ' minimal (signature=8;header=13,3 rqd chunks=36 min)
            ReDim pngStream(0 To 57)
            ReadFile FileNumber, pngStream(0), 58, readRtn, ByVal 0&
            'Get FileNumber, 1, pngStream()
            If IsPNG() = True Then
                LoadPNG = True
            Else
                Exit Function
            End If
        End If
        On Error GoTo 0
        ' process using GDI+ if available
        Set cGDIp = New cGDIPlus
        If cGDIp.GDIplusLoadPNG(FileName, pngStream(), cHost, GlobalToken) = True Then
            m_Width = cHost.Width
            m_Height = cHost.Height
            LoadPNG = True
            Exit Function
        End If
        Set cGDIp = Nothing
        ptrArray = -4&
        ptrLoc = 8&                 ' next position in the file
        SetFilePointer FileNumber, ptrLoc, 0&, 0&
   End If