VB或VBA读写PNG图片并处理为透明背景的类模块/StdPNG.cls

tmtony

         ' this is a check to see if image is interlaced w/Pixelated option
            If (c_Overrides And pdPixelated) = pdPixelated Then
                If scanPass < 7 Then
                    ' when interlacing & non-alpha, we use an offscreen 24/32bit DIB
                    ' so we can quickly modify pixelated blocks. Packing bytes
                    ' for 1,2,4 bit DIBs is painful. Pixelated blocks are not 1x1,
                    ' get the width & height of this scanline's pixelated data
                    blockCX = Min(dColumn + MatrixCX(scanPass), png_Width)
                    blockCY = Min(dRow + MatrixCY(scanPass), png_Height)

                    If dBytePP = 4 Then
                        pIndex = 4
                        ' when alphablending option is used, then dBytePP will be 4.
                        ' Pixelated is also only used for non-alpha images, therefore,
                        ' pixel alphaValue will always be 255. OR that value to the color.
                        tColor = tColor Or &HFF000000
                    Else
                        pIndex = 3 ' if not 32bpp then it will be 24bpp
                    End If

                    ' loop horizontally btwn 1-8 pixels and fill with same color
                    For blkIndex = (wRowWidth * dRow) + dColumn * pIndex To (wRowWidth * dRow) + blockCX * pIndex - 1 Step pIndex
                        CopyMemory workBytes(blkIndex), tColor, pIndex
                    Next
                    ' now loop vertically, 1-7 rows & fill with the previous row
                    For blkIndex = dRow + 1 To blockCY - 1
                        CopyMemory workBytes((blkIndex * wRowWidth) + (dColumn * pIndex)), workBytes((wRowWidth * dRow) + (dColumn * pIndex)), (blockCX - dColumn) * pIndex
                    Next
                End If
            End If

            dColumn = dColumn + MatrixColAdd(scanPass)
        Loop
    End If  ' check for quick copy

    dRow = dRow + MatrixRowAdd(scanPass)
Next

' clean up & return result
CopyMemory ByVal VarPtrArray(destBytes), 0&, 4
If TSA_w.cDims Then CopyMemory ByVal VarPtrArray(workBytes), 0&, 4
ConvertPNGtoBMP = True

Exit Function

err_h:
Err.Clear
'Stop       ' un rem when debugging improper display
'Resume
If TSA.cDims Then CopyMemory ByVal VarPtrArray(destBytes), 0&, 4
If TSA_w.cDims Then CopyMemory ByVal VarPtrArray(workBytes), 0&, 4
End Function


Private Function ExtractText() As String
' // LaVolpe, Dec 1 thru 10 - Added; consolidated into one function
' Function extracts all the text chunks found within the PNG

'http://www.w3.org/TR/PNG/#11tEXt
'http://www.w3.org/TR/PNG/#11zTXt
'http://www.w3.org/TR/PNG/#11iTXt

    ' see if any text items were found?
    If IsArrayEmpty(Not png_Comments) Then Exit Function
        
    Dim Ptr As Long, ChunkName As Long, chunkSize As Long, textLen As Long
    Dim sText As String, sKeyWord As String
    Dim sBytes() As Byte
    Dim deflateSize As Long, lRtn As Long
   
    On Error GoTo EndTextData ' in case of garbled or corrupted data
   
    Do
   
        ' extract the text chunk size & chunk name
        CopyMemory chunkSize, png_Comments(Ptr), &H4
        CopyMemory ChunkName, png_Comments(Ptr + 4), &H4
        Ptr = Ptr + 8   ' adjust pointer
   
        Select Case ChunkName
        
        Case chnk_tEXt  ' uncompressed text format
            'Keyword:        1-79 bytes (character string)
            'Null separator: 1 byte
            'Text:           n bytes (character string)
            
            sKeyWord = GetKeyWord(Ptr)  ' get the keyword from the chunk
            If Len(sKeyWord) Then
            
                If Len(sText) Then sText = sText & vbCrLf

                ' determine where in the chunk the actual text begins skipping the null separator
                textLen = chunkSize - Len(sKeyWord) - 1 ' cache calculation
               
                ' build byte array to use strConv on
                ReDim sBytes(0 To textLen - 1)
                CopyMemory sBytes(0), png_Comments(Ptr + Len(sKeyWord) + 1), textLen
                ' per png specs; don't allow ESC to be returned
                sText = sText & sKeyWord & ": " & Replace$(StrConv(sBytes(), vbUnicode), vbKeyEscape, " ")
               
            End If
            
        Case chnk_zTXt ' compressed text format
            'Keyword:            1-79 bytes (character string)
            'Null separator:     1 byte
            'Compression method: 1 byte
            'Compressed Text:    n bytes
        
            sKeyWord = GetKeyWord(Ptr)  ' get the keyword from the chunk
            If Len(sKeyWord) Then
            
                textLen = Len(sKeyWord) + Ptr + 2 ' position in array where text starts
                ' if the compression byte isn't zero, we will abort
                If png_Comments(textLen - 1) = 0 Then
               
                    On Error Resume Next
                    If Len(sText) Then sText = sText & vbCrLf
               
                    ' no way of knowing what the uncompressed size really is. Guesstimate
                    deflateSize = chunkSize + chunkSize
                    Do
                        ' oversize array & try to uncompress
                        ReDim sBytes(0 To deflateSize)
                        lRtn = Zuncompress(sBytes(0), deflateSize, png_Comments(textLen), chunkSize)
                        
                        If lRtn = 0 Then
                            ' done, the deflateSize is the actual decompressed length
                            ReDim Preserve sBytes(0 To deflateSize - 1)
                            ' per png specs; don't allow ESC to be returned
                            sText = sText & sKeyWord & ": " & Replace$(StrConv(sBytes, vbUnicode), vbKeyEscape, " ")
                            Exit Do
                        
                        Else ' didn't uncompress; try again?
                           
                            ' didn't supply a big enough buffer; increment it & try again
                            ' Note: theoretically, this could go to 200+MB.
                            ' Use commonsense assuming compression will always be < 500%
                            deflateSize = deflateSize + chunkSize * 2
                            If deflateSize > chunkSize * 50 Then Exit Do ' is this enough?
                            If Err Then
                                Err.Clear
                                Exit Do
                            End If
                        End If
                    Loop
                End If  ' valid compression byte check
            End If ' valid keyword check
            
        
        Case chnk_iTXt  ' to do; unicode
        
        End Select
        
        Ptr = Ptr + chunkSize
        Erase sBytes
        
        ' ptr will be a position within the png_Comments array
    Loop Until Ptr > UBound(png_Comments)
        
        
EndTextData:
    ' do some simple formatting for VB purposes:
    sText = Replace$(sText, vbCrLf, vbLf)
    sText = Replace$(sText, vbLf, vbCrLf)
    ExtractText = sText
   
End Function

Private Function GetBytesPerPixel(totalWidth As Long, 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)
    GetBytesPerPixel = (totalWidth * btsPerPixel + 7) \ 8

End Function

Private Sub GetDepthInfo(destBitPP As Byte, destBytePP As Byte, _
                rawBitsPP As Byte, rawBytesPP As Byte)
   
' returns the bits per pixel & bytes per pixel for the destination bitmap
' and also the respective values for the png image
   
' PNG > DIB bmp (per pixel) conversion chart I use throughout the routines:
'Color Type     bit depth   PNG bits/bytes per pixel  BMP bits/bytes pp (ignore alpha)
'----------     ---------   ------------------------- --------------------------------
'0 gray scale   1                   1   1                   1   1   (1  1)
'               2                   2   1                   4   1   (4  1)
'               4                   4   1                   4   1   (4  1)
'               8                   8   1                   8   1   (8  1)
'               16                  16  2                   8   1   (8  1)

'2 true color   8                   24  3                   24  3   (24 3)
'               16                  48  6                   24  3   (24 3)

'3 palette      1                   1   1                   1   1   (1  1)
'               2                   2   1                   4   1   (4  1)
'               4                   4   1                   4   1   (4  1)
'               8                   8   1                   8   1   (8  1)
'               16                  16  2                   8   1   (8  1)

'4 gray+alpha   8                   16  2                   32  4   (24 3)
'               16                  32  4                   32  4   (24 3)

'6 true+alpha   8                   32  4                   32  4   (24 3)
'               16                  64  8                   32  4   (24 3)

'any bit depth that uses simple transparency (trns chunk)   32  4   (n/a)
'any bit depth where AlphaBlend option is used              32  4   (n/a)

tmtony

' Special cases. When user wants to overwrite transparency with a
'   non-transparent color (setting the TransparentStyle to anything other than
'   alphaTransparent), then the final bitmap is converted from 32bpp Alpha
'   to 24bpp non-alpha and transparency is lost. If transparency is desired,
'   and also a different bkg color is desired, you should load PNG and then
'   Paint it to an offscreen DC which contains a bitmap of the color wanted.
'--------------------------------------------------------------------------

    Select Case png_ColorType
    Case 6 ' true color w/alpha (only 8,16 bpp pngs)
        If (c_Overrides And pdNoAlpha) = pdNoAlpha Then
            destBitPP = 24: destBytePP = 3 ' scale down if no alpha is being used
        Else
            destBitPP = 32: destBytePP = 4
        End If
        rawBytesPP = 4 * (png_BitDepth \ 8): rawBitsPP = png_BitDepth * 4
    Case 4: ' grayscale w/alpha (only 8,16 bpp pngs)
        If (c_Overrides And pdNoAlpha) = pdNoAlpha Then
            destBitPP = 24: destBytePP = 3 ' scale down if no alpha is being used
        Else
            destBitPP = 32: destBytePP = 4
        End If
        rawBytesPP = 2 * (png_BitDepth \ 8): rawBitsPP = png_BitDepth * 2
    Case 2: ' true color (rgb triples) (8,16 bpp pngs)
        destBitPP = 24: destBytePP = 3
        rawBytesPP = 3 * (png_BitDepth \ 8): rawBitsPP = png_BitDepth * 3
    Case 0 ' grayscale images (all bit depths)
        If png_BitDepth = 2 Then ' special case as MS bitmaps don't do 2bpp
            destBitPP = 4: destBytePP = 1: rawBytesPP = 1: rawBitsPP = 2
        ElseIf png_BitDepth > 4 Then ' (8,16 bpp pngs)
            destBitPP = 8: destBytePP = 1
            rawBytesPP = png_BitDepth \ 8: rawBitsPP = png_BitDepth
        Else ' (1,4 bpp pngs)
            destBitPP = png_BitDepth: destBytePP = 1
            rawBytesPP = 1: rawBitsPP = png_BitDepth
        End If
    Case 3: ' palette entries (1,2,4,8 bpp pngs)
        If png_BitDepth = 2 Then destBitPP = 4 Else destBitPP = png_BitDepth
        destBytePP = 1: rawBytesPP = 1: rawBitsPP = png_BitDepth
    End Select

    ' tweak for transparency which doesn't affect the actual png bitcounts:
    If c_TransColor > -1 And (c_Overrides And pdNoAlpha) = 0 Then
        ' If any transparency is used unless alpha is being prohibited
        destBitPP = 32: destBytePP = 4
    ElseIf ((c_Overrides And pd32bit) = pd32bit) Then
        destBitPP = 32: destBytePP = 4 ' force if user wants it forced
    ElseIf ((c_Overrides And pdFadeIn) = pdFadeIn) And png_Interlacing = 1 Then
        ' when fade-in interlaced, use transparency
        destBitPP = 32: destBytePP = 4
    End If

End Sub

Private Function GetKeyWord(fromPtr As Long) As String

' // LaVolpe, Dec 1 thru 10 - Added, returns keyword from tEXt or zTXt

Dim zTxtStart As Long
Dim txtData() As Byte

For zTxtStart = fromPtr To 80 + fromPtr
    ' per specs, the text name must not have chr$(0) in it
    ' look for the chr$(0) which would be the end of the text keyword
    If png_Comments(zTxtStart) = 0 Then ' null character
        ' copy the keyword into tmp array & convert from binary to ascii
        ReDim txtData(0 To zTxtStart - fromPtr - 1)
        CopyMemory txtData(0), png_Comments(fromPtr), zTxtStart - fromPtr
        GetKeyWord = StrConv(txtData, vbUnicode)
        Exit For
    End If
Next

End Function


Private Function GetPaletteValue(ByVal PixelPos As Long, PixelValue As Byte, _
                Optional RtnIndex As Long, Optional SwapRGB As Boolean) As Long
' // LaVolpe, Dec 1 thru 10 - added from scratch
' with progressive display and alphablending is it is necessary to be able to read
' any pixel regardless of the format/color depth. I am not 100% sure that these
' formulas are exact. Feel free to correct any mistakes I made

' Note: the bytes when received here will be in left to right order
' In other words, position 0 will be bit 7
' A lot of bit shifting going on here

    Dim Offset As Byte
    Dim rgbDat(0 To 2) As Byte
    Dim Color As Long

    Select Case png_BitDepth
    Case 1: ' 2 color palette (each bit represents entry in the palette or 8 pixels per byte)
        ' passed PixelPos is the 0-based position in the byte passed
        ' passed PixelValue is the value returned from the png stream

        ' convert the PixelPosition to a bit which would be the palette index
        If PixelPos < 0 Then    ' pixelvalue is the index
            RtnIndex = PixelValue
        Else
            Offset = (PixelPos + 1) Mod 8
            If Offset Then Offset = 8 - Offset
            RtnIndex = (PixelValue \ pow2x8(Offset)) And &H1
        End If
        If png_ColorType = 0 Then  ' grayscale
            Color = vbWhite * RtnIndex  ' b&w: 0=black, 1=white
            ' swapping colors if requested not necessary as Black/White reversed is still Black/White
        Else
            ' 2 color palette: 0=1st color, 1=2nd color
            Color = RtnIndex * 3
            If SwapRGB Then
                Color = png_Palette(Color + 2) Or (png_Palette(Color + 1) * 256&) Or (png_Palette(Color) * 65536)
            Else
                CopyMemory Color, png_Palette(Color), &H3
            End If
        End If

    Case 2: ' 4 pixels per byte, 4 color palette
        ' same logic as above, except 2 bits = 1 pixel
        ' Possible values will be 0-3
        If PixelPos < 0 Then ' pixelvalue is the index
            RtnIndex = PixelValue
        Else
            Offset = (PixelPos + 1) Mod 4
            If Offset Then Offset = 4 - Offset
            RtnIndex = (PixelValue \ pow2x8(Offset * 2)) And &H3
        End If
        If png_ColorType = 3 Then ' paletted
            Color = RtnIndex * 3
            If SwapRGB Then
                Color = png_Palette(Color + 2) Or (png_Palette(Color + 1) * 256&) Or (png_Palette(Color) * 65536)
            Else
                CopyMemory Color, png_Palette(Color), &H3
            End If
        Else ' grayscale; no palette provided
            ' swapping grayscale if requested is unnecessary
            RtnIndex = RtnIndex * 85
            Color = RtnIndex + RtnIndex * 256& + RtnIndex * 65536
        End If

    Case 4: ' 2 pixels per byte, 16 color palette
        If PixelPos < 0 Then ' pixelvalue is the index
            RtnIndex = PixelValue
        Else
            If PixelPos = 0 Then RtnIndex = (PixelValue And 240) \ 16 Else RtnIndex = PixelValue And 15
        End If
        If png_ColorType = 3 Then ' paletted
            Color = RtnIndex * 3
            If SwapRGB Then
                Color = png_Palette(Color + 2) Or (png_Palette(Color + 1) * 256&) Or (png_Palette(Color) * 65536)
            Else
                CopyMemory Color, png_Palette(Color), &H3
            End If
        Else ' grayscale; no palette provided
            ' swapping grayscale if requested is unnecessary
            Color = RtnIndex * 17
            Color = Color Or Color * 256& Or Color * 65536
        End If

    Case 8, 16: ' 1 pixel per byte, 256 color palette
        RtnIndex = PixelValue
        If png_ColorType = 3 Then 'paletted
            Color = RtnIndex * 3
            If SwapRGB Then
                Color = png_Palette(Color + 2) Or (png_Palette(Color + 1) * 256&) Or (png_Palette(Color) * 65536)
            Else
                Color = png_Palette(Color) + png_Palette(Color + 1) * 256& + png_Palette(Color + 2) * 65536
            End If
        Else 'grayscale; no palette provided
            ' swapping grayscale if requested is unnecessary
            Color = PixelValue + PixelValue * 256& + PixelValue * 65536
        End If

    End Select

    GetPaletteValue = Color

End Function

Private Function IsArrayEmpty(ByVal lArrayPointer As Long) As Boolean
' // LaVolpe, Dec 1 thru 10
  ' test to see if an array has been initialized
  IsArrayEmpty = (lArrayPointer = -1)
End Function

Private Function MakeAlphaPixel(Color As Long, X As Long, Y As Long, alphaByte As Long) As Long

' // LaVolpe, Dec 1 thru 10
' Under construction::: This may be a helper function to use for Win95
' Still need to test stretching an image and getting appropriate alphablends
'       without using the AlphaBlend API

' This routine is only used when specifically selected or the operating system
' cannot use GDIplus or AlphaBlend. Slowest method & primarily for (Win95/NT4<)
' http://en.wikipedia.org/wiki/History_of_Microsoft_Windows

Dim alphaColor As Long
Dim srcColor(0 To 2) As Byte
Dim pngColor(0 To 2) As Byte

Select Case alphaByte
Case 255: alphaColor = Color   ' fully opaque
'Case 0: alphaColor = GetPixel(m_PicBox.hDC, X, Y) ' fully transparent
Case Else
    'CopyMemory srcColor(0), GetPixel(m_PicBox.hDC, X, Y), &H3
    CopyMemory pngColor(0), Color, &H3
    srcColor(0) = (alphaByte * (0 + pngColor(0) - srcColor(0))) \ 255 + srcColor(0)
    srcColor(1) = (alphaByte * (0 + pngColor(1) - srcColor(1))) \ 255 + srcColor(1)
    srcColor(2) = (alphaByte * (0 + pngColor(2) - srcColor(2))) \ 255 + srcColor(2)
    CopyMemory alphaColor, srcColor(0), &H3
End Select

MakeAlphaPixel = alphaColor
End Function

Private Function Min(valA As Long, ValB As Long) As Long
' // LaVolpe, Dec 1 thru 10 - helper function for progressive display
    If valA < ValB Then
        Min = valA
    Else
        Min = ValB
    End If
End Function

tmtony

Private Sub PackByte(srcByte As Byte, DestByte As Byte, ByVal byteOffsetSrc As Long, ByVal destOffset As Byte)

' // LaVolpe, Dec 1 thru 10 - added from scratch
' Function modifies a 1, 2 or 4 bit per pixel byte

Dim bitPtr As Byte  ' value of the bit or bits at the specified position

Select Case png_BitDepth
Case 1 ' 8 bits per pixel, 8 pixels per byte
    ' we need to value of the bit (either 0 or 1) from the passed source byte
    ' the source positions will be inverted
    byteOffsetSrc = (byteOffsetSrc + 1) Mod 8
    If byteOffsetSrc Then byteOffsetSrc = 8 - byteOffsetSrc
    bitPtr = (srcByte \ pow2x8(byteOffsetSrc)) And &H1
    ' get the position in the destination byte where the bit will be placed
    destOffset = (destOffset + 1) Mod 8
    ' the bitmap's rgb values are also inverted BGR vs RGB
    If destOffset Then destOffset = 8 - destOffset
    ' place the bit at that position
    DestByte = DestByte Or (bitPtr * pow2x8(destOffset))
   
Case 4 ' 4 bits per pixel, 2 pixels per byte
    ' same logic as above except the value we want is contained in 4 bits
    If byteOffsetSrc Then
        bitPtr = srcByte And 15
    Else
        bitPtr = (srcByte And 240) \ 16
    End If
    destOffset = destOffset Xor 1
    DestByte = DestByte Or (bitPtr * pow2x8(destOffset * 4))

Case 2 ' the BITMAPINFO needed for CreateDIBitmap or CreateDibSection does
       ' appears to not support 2 bits per pixel formats. Therefore, we will
       ' will convert a 2bpp png image to a 4bpp image. Not too difficult
    byteOffsetSrc = (byteOffsetSrc + 1) Mod 4
    If byteOffsetSrc Then byteOffsetSrc = 4 - byteOffsetSrc
    bitPtr = ((srcByte \ (pow2x8(byteOffsetSrc * 2))) And &H3)
    destOffset = destOffset Xor 1
    DestByte = DestByte Or (bitPtr * pow2x8(destOffset * 4))
   


Case Else
   

End Select

End Sub
Private Function PaethPredictor(Left As Integer, Above As Integer, UpperLeft As Integer) As Integer

' // LaVolpe, Dec 1 thru 10 - rewrote for understanding & commented/linked

' http://www.w3.org/TR/PNG/#9-table91
' algorithm is used for both encoding & decoding the png image's filter
' based off of the formula created by Alan W. Paeth & provided fully in url above


    Dim pa As Integer, pB As Integer, pC As Integer, p As Integer
    p = Left + Above - UpperLeft
    pa = Abs(p - Left)
    pB = Abs(p - Above)
    pC = Abs(p - UpperLeft)

    ' tie breaker
    ' The order in which the comparisons are performed is critical and shall not be altered
    If (pa <= pB) And (pa <= pC) Then
     PaethPredictor = Left
    ElseIf pB <= pC Then
     PaethPredictor = Above
    Else
     PaethPredictor = UpperLeft
    End If

End Function

Private Sub DecodeFilter_Avg(Filtered() As Byte, UnFiltered() As Byte, RowNr As Long, ScanLine As Long, stepVal As Byte, Optional iOffset As Long)

' // LaVolpe, Dec 1 thru 10 - rewrote for understanding; nothing wrong with original
'http://www.w3.org/TR/PNG/#9-table91
'Filters may use the original values of the following bytes to generate the new byte value:
'
'x  the byte being filtered;
'a  the byte corresponding to x in the pixel immediately before the pixel containing x (or the byte immediately before x, when the bit depth is less than 8);
'b  the byte corresponding to x in the previous scanline;
'c  the byte corresponding to b in the pixel immediately before the pixel containing b (or the byte immediately before b, when the bit depth is less than 8).

' algorithm: Recon(x) = Filt(x) + floor((Recon(a) + Recon(b)) / 2)
' Unsigned arithmetic modulo 256 is used, so that both the inputs and outputs fit into bytes

    Dim ppLeft As Integer, ppTop As Integer
    Dim X As Long, startByte As Long

    startByte = RowNr * ScanLine - RowNr - 1

    For X = startByte + 1 To startByte + ScanLine - 1

        If RowNr Then ppTop = UnFiltered(X - ScanLine + 1)
        If X - stepVal > startByte Then ppLeft = UnFiltered(X - stepVal)

        UnFiltered(X) = (0 + Filtered(X + RowNr + 1 + iOffset) + (ppLeft + ppTop) \ 2) Mod 256

    Next

End Sub

Private Sub DecodeFilter_Paeth(Filtered() As Byte, UnFiltered() As Byte, RowNr As Long, ScanLine As Long, stepVal As Byte, Optional iOffset As Long)

' // LaVolpe, Dec 1 thru 10 - rewrote for understanding; nothing wrong with original
'http://www.w3.org/TR/PNG/#9-table91

'Filters may use the original values of the following bytes to generate the new byte value:
'
'x  the byte being filtered;
'a  the byte corresponding to x in the pixel immediately before the pixel containing x (or the byte immediately before x, when the bit depth is less than 8);
'b  the byte corresponding to x in the previous scanline;
'c  the byte corresponding to b in the pixel immediately before the pixel containing b (or the byte immediately before b, when the bit depth is less than 8).

' algorithm: Recon(x) = Filt(x) + PaethPredictor(Recon(a), Recon(b), Recon(c))
' Unsigned arithmetic modulo 256 is used, so that both the inputs and outputs fit into bytes

    Dim ppLeft As Integer, ppTop As Integer, ppTopLeft As Integer
    Dim X As Long, startByte As Long

    startByte = RowNr * ScanLine - RowNr - 1

    For X = startByte + 1 To startByte + ScanLine - 1

        If X - stepVal > startByte Then ' we are not on the 1st pixel
            ppLeft = UnFiltered(X - stepVal)
            If RowNr Then
                ppTop = UnFiltered(X - ScanLine + 1)
                ppTopLeft = UnFiltered(X - ScanLine + 1 - stepVal)
            End If
        Else
            If RowNr Then ppTop = UnFiltered(X - ScanLine + 1)
        End If

        UnFiltered(X) = (Filtered(X + RowNr + 1 + iOffset) + PaethPredictor(ppLeft, ppTop, ppTopLeft)) Mod 256

    Next

End Sub

Private Sub DecodeFilter_Sub(Filtered() As Byte, UnFiltered() As Byte, RowNr As Long, ScanLine As Long, stepVal As Byte, Optional iOffset As Long)

' // LaVolpe, Dec 1 thru 10 - rewrote for understanding; nothing wrong with original
'http://www.w3.org/TR/PNG/#9-table91

'Filters may use the original values of the following bytes to generate the new byte value:
'
'x  the byte being filtered;
'a  the byte corresponding to x in the pixel immediately before the pixel containing x (or the byte immediately before x, when the bit depth is less than 8);
'b  the byte corresponding to x in the previous scanline;
'c  the byte corresponding to b in the pixel immediately before the pixel containing b (or the byte immediately before b, when the bit depth is less than 8).

' algorithm: Recon(x) = Filt(x) + Recon(a)
' Unsigned arithmetic modulo 256 is used, so that both the inputs and outputs fit into bytes

    Dim startByte As Long
    Dim n As Long, X As Long

    startByte = RowNr * ScanLine - RowNr
    ' 1st n bytes for 1st pixel are unfiltered
    CopyMemory UnFiltered(startByte), Filtered(startByte + RowNr + 1 + iOffset), stepVal

    For n = startByte + stepVal To startByte + ScanLine - 2 Step stepVal
        For X = n To n + stepVal - 1
            UnFiltered(X) = (0 + UnFiltered(X - stepVal) + Filtered(X + RowNr + 1 + iOffset)) Mod 256
        Next
    Next

End Sub

tmtony

Private Sub DecodeFilter_Up(Filtered() As Byte, UnFiltered() As Byte, RowNr As Long, ScanLine As Long, Optional iOffset As Long)

' // LaVolpe, Dec 1 thru 10 - rewrote for understanding; nothing wrong with original
'http://www.w3.org/TR/PNG/#9-table91

'Filters may use the original values of the following bytes to generate the new byte value:
'
'x  the byte being filtered;
'a  the byte corresponding to x in the pixel immediately before the pixel containing x (or the byte immediately before x, when the bit depth is less than 8);
'b  the byte corresponding to x in the previous scanline;
'c  the byte corresponding to b in the pixel immediately before the pixel containing b (or the byte immediately before b, when the bit depth is less than 8).

' algorithm:  Recon(x) = Filt(x) + Recon(b)
' Unsigned arithmetic modulo 256 is used, so that both the inputs and outputs fit into bytes
   
    Dim startByte As Long
    Dim X As Long, ppTop As Integer
   
    startByte = RowNr * ScanLine - RowNr
   
    For X = startByte To startByte + ScanLine - 2
        If RowNr Then ppTop = UnFiltered(X - ScanLine + 1)
        UnFiltered(X) = (ppTop + Filtered(X + RowNr + 1 + iOffset)) Mod 256
    Next

End Sub

Private Function UnfilterInterlaced(Filtered() As Byte, _
            tgtDC As Long, tgtWindow As Long, dcX As Long, dcY As Long, AlphaBlend As Byte) As Boolean

' // LaVolpe, Dec 1 thru 10 - built from scratch

' ToDo: this routine assumes pixels are 1x1 squares. With a 6:9 aspect ratio,
'   the routine will not scale. This should be adjusted when the routines are
'   fully capable of supporting aspect ratios of other than 1:1 or should it be stretched?

' http://www.libpng.org/pub/png/sp ... terlaced-data-order

' Progressive display/scan order per 8 pixel blocks (64 total pixels)
'   1 6 4 6 2 6 4 6     ' 1st scan: 1 pixel (@col 0), row 0 [1/64 of total image]
'   7 7 7 7 7 7 7 7     ' 2nd scan: 1 pixel (@col 4), row 0 [1/32 of image shown]
'   5 6 5 6 5 6 5 6     ' 3rd scan: 2 pixels (@cols 0:4), row 4 [1/16 of image]
'   7 7 7 7 7 7 7 7     ' 4th scan: 4 pixels (@cols 2:6), rows 0:4 [1/8]
'   3 6 4 6 3 6 4 6     ' 5th scan: 8 pixels (@cols 0:2:4:6), rows 2:6 [1/4]
'   7 7 7 7 7 7 7 7     ' 6th scan: 16 pixels (@cols 1:3:5:7), rows 0:2:4:6 [1/2]
'   5 6 5 6 5 6 5 6     ' 7th scan: 32 pixels (@cols all), rows 1:3:5:7 [100%]
'   7 7 7 7 7 7 7 7                 64 pixels, 15 scanlines over 7 passes

' Note : all logic in this routine is based off of the above grid.
' Scanline widths are only guaranteed to be same for each scanline in the same pass.
' Scanlines can be padded both horizontally & vertically if the image doesn't fit into
'   a nice 8x8 grid evenly.
' Each scanline in interlaced image is also filtered, but they are filtered in relation
' to only the other scanlines in the same pass, different than non-interlaced images.
' Think of non-interlaced images as single-pass interlaced images.

    ' counter variables
    Dim Pass As Byte, srcRow As Long
    ' sizing/bit alignment variables
    Dim nr8wide As Long, nr8high As Long
    Dim nrBytes As Long, passPtr As Long
    ' our temporary arrays
    Dim UnFiltered() As Byte     ' the unfiltered, complete image
    Dim InterlacePass() As Byte  ' unfiltered progressive display (used 7x for 7 passes)
    ' bytes and bits per pixel values
    Dim bytesPP As Byte, BPRow As Long, bitPP As Byte, bmpBPP As Byte
    ' allows direct memory access (DMA) to the DIB bits
    Dim TSA As SafeArray1D
   
    ' need bit & byte information
    GetDepthInfo bmpBPP, 0, bitPP, bytesPP
    ' create safearray structure
    With TSA
        .cDims = 1                          ' Number of dimensions
        .cbElements = 1                     ' Size of data elements
        .pvData = cPNGimage.PngDataPtr             ' Data address
        .rgSABound.lLbound = 0              ' Low bound of array
        .rgSABound.cElements = cPNGimage.PngDataSize ' Nr of elements in array
    End With

    ' overlay the safearray over our uninitialized array
    CopyMemory ByVal VarPtrArray(UnFiltered), VarPtr(TSA), 4

    ' interlaced images always come in 7 passes; although not all passes may be used
    For Pass = 1 To 7
   
        ' ensure bounds are valid. If image is smaller than 8x8 not all passes are valid/used
        ' Tested with images as small as 1x1
   
        ' calculate nr of pixels for this pass that will fit in width of image
        nr8wide = png_Width \ MatrixColAdd(Pass) - (png_Width Mod MatrixColAdd(Pass) > MatrixCol(Pass))
        If nr8wide > 0 Then
            
            ' calcuate nr of rows for this pass that will fit in height of image
            nr8high = png_Height \ MatrixRowAdd(Pass) - (png_Height Mod MatrixRowAdd(Pass) > MatrixRow(Pass))
            If nr8high > 0 Then
   
                ' calculate row bytes for the interlaced image, byte aligned
                BPRow = GetBytesPerPixel(nr8wide, bitPP)
                ' how many bytes are needed for the complete pass, less filter byte?
                nrBytes = BPRow * nr8high
                BPRow = BPRow + 1
                '^^ the filter routines expect the filter byte to be in its parameters, so add it
               
                ' size the temp array to hold the unfiltered scanlines. This will be transfered over
                ' to the unfiltered array after unfiltering has been accomplished
                If Pass = 1 Then
                    ReDim InterlacePass(0 To nrBytes)
                ElseIf nrBytes > UBound(InterlacePass) Then
                    '^^ array could be large; don't resize if unnecessary
                    ReDim InterlacePass(0 To nrBytes - 1)
                End If
   
                ' unfilter the scanlines
                For srcRow = 0 To nr8high - 1
                    Select Case Filtered(BPRow * srcRow + passPtr)
                    Case 0: ' no filtering, straight copy to our temp array
                        CopyMemory InterlacePass(srcRow * BPRow - srcRow), Filtered(BPRow * srcRow + passPtr + 1), BPRow - 1
                    Case 1: ' sub filter
                        DecodeFilter_Sub Filtered, InterlacePass, srcRow, BPRow, bytesPP, passPtr
                    Case 2: ' up filter
                        DecodeFilter_Up Filtered, InterlacePass, srcRow, BPRow, passPtr
                    Case 3: ' average filter
                        DecodeFilter_Avg Filtered, InterlacePass, srcRow, BPRow, bytesPP, passPtr
                    Case 4: ' paeth filter
                        DecodeFilter_Paeth Filtered, InterlacePass, srcRow, BPRow, bytesPP, passPtr
                    Case Else
                        ' If we got here, there is a different filtering mechanism at large
                        CopyMemory ByVal VarPtrArray(UnFiltered), 0&, 4
                        Exit Function
                    End Select
                Next
        
                ' offset the filtered array pointer to account for the 1byte filter flag per scanline
                ' This will point to the next pass's X,Y position in the Unfiltered() array
                passPtr = passPtr + nrBytes + nr8high
            
                ' send unfiltered array to be transfered to the DIB(s)
                If ConvertPNGtoBMP(InterlacePass(), Pass, nr8high, BPRow - 1, 0) = False Then Exit For
            
                ' display the interlaced pass if appropriate
                RaiseEvent Progress(Pass * 100 \ 7)
                If (c_Overrides And pdNoInterlace) = 0 Then
                    If png_Interlacing = 1 Or bmpBPP = 32 Then _
                        cPNGimage.DisplayInterlaced tgtDC, tgtWindow, dcX, dcY, MatrixRow(Pass) + 0, MatrixRowAdd(Pass) + 0&, (Pass = 7), False, c_AlphaColor, AlphaBlend
                End If
        
            End If ' check for nr8high < 1
        
        End If ' check for nr8wide < 1
   
    Next Pass

    ' remove the safearray overlay
    CopyMemory ByVal VarPtrArray(UnFiltered), 0&, 4
   
    If Pass < 8 Then Exit Function

    UnfilterInterlaced = True
   
End Function

tmtony

Private Function UnfilterNI(FilteredData() As Byte, _
            tgtDC As Long, tgtWindow As Long, dcX As Long, dcY As Long, AlphaBlend As Byte) As Boolean

' // LaVolpe, Dec 1 thru 10 - completely rewritten to remove excess large array usage
' http://www.w3.org/TR/PNG/#9-table91

    Dim UnFiltered() As Byte, Row As Long
    Dim BPRow As Long, lBpp As Byte, dBpp As Byte, stepVal As Byte
    Dim lastLineBlt As Long

    Const fauxInterlace As Long = 16
    '^^ tried other values ranging from 4 to 32 and 16 is best performance

    GetDepthInfo dBpp, 0, lBpp, stepVal
    BPRow = GetBytesPerPixel(png_Width, lBpp) + 1
    ReDim UnFiltered(0 To (BPRow - 1) * png_Height - 1)

    For Row = 0 To png_Height - 1

        Select Case FilteredData(BPRow * Row)
        Case 0 'None
            CopyMemory UnFiltered(BPRow * Row - Row), FilteredData(BPRow * Row + 1), BPRow - 1
        Case 1 'Sub
            DecodeFilter_Sub FilteredData, UnFiltered, Row, BPRow, stepVal
        Case 2 'Up
            DecodeFilter_Up FilteredData, UnFiltered, Row, BPRow
        Case 3 'Average
            DecodeFilter_Avg FilteredData, UnFiltered, Row, BPRow, stepVal
        Case 4 'Paeth
            DecodeFilter_Paeth FilteredData, UnFiltered, Row, BPRow, stepVal
        Case Else ' invalid filter type
            Exit Function
        End Select

        If Row Mod fauxInterlace = 0 Then
            If Row Then
                RaiseEvent Progress(Row * 100 \ png_Height)
                lastLineBlt = Row
                If ConvertPNGtoBMP(UnFiltered(), 8, Row, BPRow - 1, Row - fauxInterlace) = False Then Exit Function
                If (c_Overrides And pdScanner) = pdScanner Then _
                    cPNGimage.DisplayInterlaced tgtDC, tgtWindow, dcX, dcY, Row - fauxInterlace, fauxInterlace, (Row = png_Height), True, c_AlphaColor, AlphaBlend
            End If
        End If

    Next Row

    RaiseEvent Progress(100)
    If lastLineBlt < fauxInterlace Then
        If ConvertPNGtoBMP(UnFiltered(), 8, png_Height, BPRow - 1, 0) = False Then Exit Function
        If (c_Overrides And pdScanner) = pdScanner Then _
            cPNGimage.DisplayInterlaced tgtDC, tgtWindow, dcX, dcY, 0, png_Height, True, True, c_AlphaColor, AlphaBlend
    Else
        Row = png_Height - lastLineBlt
        If Row > 1 Then
            If ConvertPNGtoBMP(UnFiltered(), 8, png_Height, BPRow - 1, png_Height - Row) = False Then Exit Function
        End If
        If (c_Overrides And pdScanner) = pdScanner Then _
            cPNGimage.DisplayInterlaced tgtDC, tgtWindow, dcX, dcY, png_Height - Row, Row, True, True, c_AlphaColor, AlphaBlend
    End If
    UnfilterNI = True

End Function


Private Function ValidateDLLExists() As Boolean
    ' function ensures DLLs of interest exist in user's system path
    ' side note: DLL filename is not case-sensitive, call names are!

    Dim lb As Long, pa As Long, sRtn As String
    Dim I As Integer, sDLL As String, sCall As String

    For I = 1 To 2
        Select Case I
        Case 1
            sDLL = "zlibvb.dll": sCall = "uncompress"
        Case 2
            sDLL = "ws2_32.dll": sCall = "htonl"
        End Select
        'attempt to open the DLL to be checked
        lb = LoadLibrary(sDLL)
        'if so, retrieve the address of one of the function calls
        If lb Then pa = GetProcAddress(lb, sCall)

        If pa = 0 Then  ' nope, don't got it; can't run project
            If Len(sRtn) Then sRtn = sRtn & vbCrLf
            sRtn = sRtn & sDLL
        Else            ' got it, free references
            FreeLibrary lb
            lb = 0
            pa = 0
        End If
    Next
    If Len(sRtn) Then
        sRtn = "Following DLL(s) not found in your system path:" & vbCrLf & sRtn
        MsgBox sRtn, vbExclamation + vbOKOnly, "Missing Library"
    Else
        ValidateDLLExists = True
    End If

End Function

Private Function zChunk_bKGD(Buffer() As Byte, bufLen As Long, crcValue As Long) As String
'http://www.w3.org/TR/PNG/#11bKGD

    If crcValue Then
        If ntohl(crcValue) <> Zcrc32(0, Buffer(0), bufLen + 4) Then Exit Function
    End If

    On Error Resume Next
    Select Case png_ColorType
        Case 2, 6 ' true color with/without transparency
            png_WinBKG = Buffer(5) Or Buffer(7) * 256& Or Buffer(9) * 65536
        Case 3 ' grayscale or paletted
            png_WinBKG = GetPaletteValue(0, Buffer(4))
        Case 0, 4 ' grayscale with/without transparency
            png_WinBKG = GetPaletteValue(0, Buffer(5))
    End Select
    If Err Then
        png_WinBKG = -1 ' no suggested window background color
        Err.Clear
    End If

End Function

Private Function zChunk_IHDR(Buffer() As Byte, bufLen As Long, crcValue As Long, cmprSize As Long) As String
'http://www.w3.org/TR/PNG/#11IHDR
    ' IHDR structure
    '    Width As Long              << cannot be negative
    '    Height As Long             << cannot be negative
    '    BitDepth As Byte           << must be 1,2,4,8,16
    '    ColorType As Byte          << must be 0,2,3,4,6
    '    Compression As Byte        << must be zero
    '    Filter As Byte             << must be zero
    '    Interlacing As Byte        << must be zero or one

    On Error Resume Next
    If ntohl(crcValue) = Zcrc32(0, Buffer(0), bufLen + 4) Then

        Dim lRtn As Long, sReturn As String

        CopyMemory png_Width, Buffer(4), 4
        png_Width = ntohl(png_Width)
        CopyMemory png_Height, Buffer(8), 4
        png_Height = ntohl(png_Height)

        If png_Width < 1 Or png_Height < 1 Then
            sReturn = "Corrupted Image Header. Cannot continue."

        Else

            If Buffer(14) > 0 Then
                sReturn = "Invalid Compression Flag in Header. Cannot continue."
            Else
                If Buffer(15) > 0 Then
                    sReturn = "Invalid Filter Flag in Header. Cannot continue."
                Else

                    png_BitDepth = Buffer(12)
                    Select Case png_BitDepth
                    Case 1, 2, 4, 8, 16
                        ' it is a valid bit depth
                        png_ColorType = Buffer(13)
                        Select Case png_ColorType
                        Case 0, 2, 3, 4, 6
                            ' it is a valid color type
                            png_Interlacing = Buffer(16)
                            If png_Interlacing > 1 Then
                                sReturn = "Invalid Interlacing Flag in Header. Cannot continue."
                            End If
                        Case Else
                            sReturn = "Invalid Color Type Flag in Header. Cannot continue."
                        End Select
                    Case Else
                        sReturn = "Invalid Bit Depth Flag in Header. Cannot continue."
                    End Select

                End If  ' Filter flag
            End If  ' Compression flag
        End If  ' Dimensions

        If sReturn = "" Then
            ' check for png sizes that would cause overflow errors in other calculations...
            ' This has 2 basic checks
            ' check DWord width alignment * height first are within bounds
            lRtn = ((((png_Width * 32) + &H1F) And Not &H1F&) \ &H8) * png_Height
            ' see if uncompress png data is too long
            If Not Err Then cmprSize = CalcUncompressedWidth()
            If cmprSize = 0 Then
                If Err Then Err.Clear
                ' either the dWord aligned bytes required for the bitmap
                ' are too large (Long value) or the size of the total
                ' uncompressed pixel array is too large (Long value).
                ' Image is way too big to process anyway! would require GBs of memory
                sReturn = "Image is too large to process. Cannot continue."
            End If
        End If
    Else ' error; CRC validation failed; corrupt file
        sReturn = "Corrupted Image Header (bad CRC). Cannot continue."
    End If

    zChunk_IHDR = sReturn

End Function

Private Function zChunk_PLTE(Buffer() As Byte, bufLen As Long, crcValue As Long) As String
' http://www.w3.org/TR/PNG/#11PLTE

    If png_ColorType = 0 Or png_ColorType = 4 Then Exit Function
    '^^ per specs, palettes shall not appear for those color types
    '   Since we can ignore the palette, we won't trigger a critcal error

    If ntohl(crcValue) = Zcrc32(0, Buffer(0), bufLen + 4) Then

        ' per png specs, palette must be divisible by 3
        If (bufLen \ 3) * 3 = bufLen Then
            ReDim png_Palette(bufLen - 1)
            CopyMemory png_Palette(0), Buffer(4), bufLen
        Else ' error
            zChunk_PLTE = "Invalid Palette. Cannot continue."
        End If
    Else ' error; CRC validation failed; corrupt file
        zChunk_PLTE = "Invalid Palette (bad CRC). Cannot continue."
    End If

End Function

tmtony

Private Function zChunk_tIME(Buffer() As Byte, bufLen As Long, crcValue As Long) As String
'http://www.w3.org/TR/PNG/#11tIME

    On Error GoTo ExitMe
    If crcValue Then
        If ntohl(crcValue) <> Zcrc32(0, Buffer(0), bufLen + 4) Then Exit Function
    End If
   
    Dim iYear As Integer
    If bufLen > 6 Then ' format...7bytes
        'Year:   2 bytes (4 digits)
        'Month:  1 byte (1-12)
        'Day:    1 byte (1-31)
        'Hour:   1 byte (0-23)
        'Minute: 1 byte (0-59)
        'Second: 1 byte (0-60)
        ReDim png_LastModified(0 To 7)
        CopyMemory iYear, Buffer(4), &H2 ' year
        ' 4-digit year; convert to little endian
        iYear = ntohs(iYear)
        CopyMemory png_LastModified(0), iYear, 2      ' put year in array
        CopyMemory png_LastModified(2), Buffer(6), 5  ' put rest of date in array
    ' else not a valid chunk; however; not a critical chunk either
    End If

ExitMe:
End Function

Private Function zChunk_tRNS(Buffer() As Byte, bufLen As Long, crcValue As Long) As String
'http://www.w3.org/TR/PNG/#11tRNS
   
    If png_ColorType > 3 Then Exit Function
    ' Per specs, the tRNS chunk shall not be used for Color Types 4 and 6

    On Error GoTo ExitMe
    If ntohl(crcValue) = Zcrc32(0, Buffer(0), bufLen + 4) Then
   
        Dim UB As Long
   
        ReDim png_TransSimple(0 To bufLen - 1)
        CopyMemory png_TransSimple(0), Buffer(4), bufLen
   
        If png_ColorType = 0 Then ' grayscale with simple transparency
            c_TransColor = png_TransSimple(1) ' color-index value
        ElseIf png_ColorType = 2 Then ' rgb triple + grayscale
            ' save as BGR to be compared against PNG samples
            c_TransColor = png_TransSimple(5) Or png_TransSimple(3) * 256& Or png_TransSimple(1) * 65536
        ElseIf png_ColorType = 3 Then ' PNGhdr.TransSimple() is an array
            ' to prevent out of bounds errors, ensure array is 255
            If UBound(png_TransSimple) < 255 Then ' pngs are not required to provide all
                UB = UBound(png_TransSimple)      ' alpha values for every color in
                ReDim Preserve png_TransSimple(0 To 255) ' the palette.
                FillMemory png_TransSimple(UB + 1), 255 - UB, 255
            End If
            c_TransColor = 0 ' simply a flag > -1, has no other meaning
                             ' alpha values are in the png_TransSimple() array
        End If
        If Err Then
            Err.Clear   ' an error regarding the PNGhdr.TransSimple() array. Ignore simple transparency
            c_TransColor = -1 ' prevent transparency
        End If
   
    'Else error, but not a critical error - pic may look crappy
    End If
   
   
ExitMe:
End Function

Private Function zChunk_tEXt(Buffer() As Byte, bufLen As Long, crcValue As Long) As String
'http://www.w3.org/TR/PNG/#11tEXt
'http://www.w3.org/TR/PNG/#11zTXt

    On Error GoTo ExitMe
    If crcValue Then
        If ntohl(crcValue) <> Zcrc32(0, Buffer(0), bufLen + 4) Then Exit Function
    End If
   
    ' not needed to display image; cache & extract via property if needed
    If IsArrayEmpty(Not png_Comments) Then
        ReDim png_Comments(0 To bufLen + 7)
    Else
        ReDim Preserve png_Comments(0 To UBound(png_Comments) + bufLen + 8)
    End If
    ' save the chunk name & bytes
    CopyMemory png_Comments(UBound(png_Comments) - bufLen - 3), Buffer(0), bufLen + 4
    ' also save the chunk size already converted to proper endian
    CopyMemory png_Comments(UBound(png_Comments) - bufLen - 7), bufLen, 4

ExitMe:
End Function

Private Function zChunk_gAMA(Buffer() As Byte, bufLen As Long, crcValue As Long) As String
' http://www.w3.org/TR/PNG/#11gAMA

' Gamma correction; possibly applicable to BitmapInfoHeader v5
    On Error GoTo ExitMe
    If crcValue Then
        If ntohl(crcValue) <> Zcrc32(0, Buffer(0), bufLen + 4) Then Exit Function
    End If
   
    If bufLen = 4 Then
        CopyMemory png_Gamma, Buffer(4), 4
        png_Gamma = ntohl(png_Gamma)
    End If
   
ExitMe:
End Function

Private Function zChunk_cHRM(Buffer() As Byte, bufLen As Long, crcValue As Long) As String
' http://www.w3.org/TR/PNG/#11cHRM
   
' Chromatic information; possibly applicable to BitmapInfoHeader v5
    On Error GoTo ExitMe
    If crcValue Then
        If ntohl(crcValue) <> Zcrc32(0, Buffer(0), bufLen + 4) Then Exit Function
    End If
   
    If bufLen > 31 Then
        Dim I As Integer, lItem As Long
        ReDim png_Chromaticity(0 To 7)
        For I = 0 To 7
            CopyMemory lItem, Buffer(I * 4 + 4), 4
            png_Chromaticity(I) = ntohl(lItem)
        Next
    End If
   
ExitMe:
End Function

Private Function zChunk_pHYs(Buffer() As Byte, bufLen As Long, crcValue As Long) As String
'http://www.libpng.org/pub/png/spec/1.2/PNG-Chunks.html#C.pHYs

On Error GoTo ExitMe

    If crcValue Then
        If ntohl(crcValue) <> Zcrc32(0, Buffer(0), bufLen + 4) Then Exit Function
    End If
   
    If bufLen > 8 Then
        'Pixels per unit, X axis: 4 bytes (unsigned integer)
        'Pixels per unit, Y axis: 4 bytes (unsigned integer)
        'Unit specifier:          1 byte (1=meter with 1 inch=.0254 meters)
        Dim lItem As Long
        ReDim png_Physical(0 To 2)
        CopyMemory lItem, Buffer(4), &H4
        png_Physical(0) = ntohl(lItem)
        CopyMemory lItem, Buffer(8), &H4
        png_Physical(1) = ntohl(lItem)
        png_Physical(2) = Buffer(12)
        If Buffer(12) = 1 Then ' units is meter
            ' note to self: this appears to be a LogPixelsX/Y setting when
            ' multiplying the X,Y ppu by .0254 (meters per inches)
            '   Example: if pixels per unit = 2834 or 3780
            '   CLng(2834 * .0254) = 72, CLng(3780 * .0254) = 96
            ' therefore, these values could be used with API SetViewportExtEx ?
        Else
            ' values are an aspect ratio; possibly for windows media centers?
            ' http://msdn.microsoft.com/librar ... ixelaspectratio.asp
            ' But for hDCs, maybe stretchblt to that ratio? or from that ratio?
        End If
    ' else invalid chunk
    End If
   
ExitMe:
End Function

Private Function zChunk_oFFs(Buffer() As Byte, bufLen As Long, crcValue As Long) As String
' http://www.libpng.org/pub/png/book/chapter11.html#png.ch11.div.10

' physical offset of image (primarily used for printing, but could be for display too.
    On Error GoTo ExitMe
   
    If crcValue Then
        If ntohl(crcValue) <> Zcrc32(0, Buffer(0), bufLen + 4) Then Exit Function
    End If
   
    If bufLen > 8 Then
        Dim lItem As Long
        ReDim png_Offsets(0 To 2)
        CopyMemory lItem, Buffer(4), &H4
        png_Offsets(0) = ntohl(lItem)         ' left offset
        CopyMemory lItem, Buffer(8), &H4
        png_Offsets(1) = ntohl(lItem)         ' top offset
        png_Offsets(2) = Buffer(9)            ' unit: either pixel(0) or micron(1)
    End If

ExitMe:
End Function

Private Function zChunk_sRGB(Buffer() As Byte, bufLen As Long, crcValue As Long) As String
' http://www.libpng.org/pub/png/spec/1.2/PNG-Chunks.html#C.sRGB
   
    If crcValue Then
        If ntohl(crcValue) <> Zcrc32(0, Buffer(0), bufLen + 4) Then Exit Function
    End If
    ' real values will be btwn 0 and 3, but tweaked so 0 means no sRGB chunk rcvd
    If Buffer(4) < 4 Then png_sRGB = Buffer(4) + 1
    '0: Perceptual
    '1: Relative colorimetric
    '2: Saturation
    '3: Absolute colorimetric

End Function

zhuyiwen

这么长，弄成一个文件多好啊

李力军2

看不懂啊,楼主们能上个实例就更好了