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

tmtony · 发表于 2015-6-27 19:33:15

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "StdPNG"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'Download by http://www.codefans.net
Option Explicit
' ZLIB Specific Instructions: Don't follow these instructions & project will NOT work!
' 1. Go to http://www.winimage.com/zLibDll/zlib123dll.zip
' 2. Save the Zip file to your desktop
' 3. Open the zip file and extract to your desktop the file named: zlibwapi.dll
' 4. Rename the zlibwapi.dll to zlibVB.dll
' If you opted to use Folder Names while unzipping, the DLL will be in a
' folder named Dll32, also on your desktop
' 5. Move that file to your system folder. No DLL registration is needed
' 6. Delete/clean up any desktop items that resulted from the previous 5 steps.
' 7. After playing with project, delete the DLL from your system folder if desired
' 8. If for some reason you cannot get to that website. Email me for a copy: LaVolpeVB@hotmail.com

' CALLING ALL CODERS!!!
' Let's try to make the best PNG project on PSC and share it with everyone. Asking each
' of you to take a look at the code provided & improve and add upon it. Every coder has
' their own area of expertise and could make this a better or more accurate/efficient
' project. Note that many of the png chunks are not handled; up to you to help there.

' I'm thinking that everyone who wants to improve this should do so and repost it
' under their handle. To keep things somewhat organized, suggest following when
' updating/reposting:
' 1. Copy & paste the top portion of this module into your new version
' so it is carried over to your new version
' 2. Mark your changes with your handle & date/time
' 3. Always include link to the other revisions
' - this way we can see what was changed & possibly reuse code no longer in current version
'    For example. In my revision here, I removed the vb-only code to decode png compression,
'    but that information is extremely good -- find it in the original: Version 0
' 4. Find a section that fits your expertise. Take a crack at modifying the routines
' to handle any unhandled chunks; there are many things to do at this point.
' 5. Suggest the name for this project & posting: PNG Reader/Writer
' 6. Add other references as needed to help others improve upon this too.
' 7. Shouldn't have to be asked, but comment your code/improvements as much as possible

'=========================================================================
' PROJECT HISTORY.... When you update & repost, add your's here too

' Version 0. Original Code: 10/5/2004, by alfred.koppold (txtCodeId=56537)
' Version 1. 31 Dec 2005, by LaVolpe, (txtCodeID= ) << fill in please
' Version ?
'=========================================================================
' REFERENCES:
' PNG links of interest:
'    1: http://www.libpng.org/pub/png/book/toc.html
'    2: http://www.libpng.org/pub/png/spec/1.2/PNG-Contents.html
'    3: http://www.libpng.org/pub/png/png-sitemap.html
'    4: http://www.libpng.org/pub/png/pngsuite.html  <<(png test images)
'    5: http://www.winimage.com/zLibDll/zlib123dll.zip <<(VB6 friendly ZLIB.dll)
'    6: review the ReaderREADME.rtf file
'=========================================================================
' Copy & paste everything above this line to your latest revision before posting on PSC

tmtony · 发表于 2015-6-27 19:34:41

' // LaVolpe, Dec 2005
' My contributions to the Original Code (Ver.0).
' 1. Speed Improvements, even with all the extra safety checks.
'    When compiled my routines are 2 to 6 times faster than Ver.0 compiled version
'    My routines are up to 10x faster compiled than uncompiled depending on compression/alpha
' 2. Ver.0 didn't handle zero-byte blocks & would error going past EOF
' 3. Ver.0 didn't offer progressive display. Interlacing routines were slow
'    In fact 4 progressive displays are provided:
'    a. Fade in for interlaced images with transparency. Only option for transparent interlaced images
'    b. Fade in for non-alpha interlaced
'    c. Pixelated progression for non-alpha interlaced
'    d. Scanner effect for non-interlaced images (nice effect on very large pngs)
'    e. Prevent interlacing (is this a 5th option?)
'    ^^ Progressive display while stretching an image is not available (too costly in time)
' 4. Ver.0 used pure vb decompression routines, but provided no compression; now ref's zlib dll
'    Note. Pure VB is good, but w/o compression routines; can't write png files
'          Therefore, using zlib to write & read compression & do CRC checks
'    Speed improvement: a non-interlaced 960x860 png. Ver.0=5.2 secs, w/zlib=1.8 secs
' 5. Ver.0 drew some 24bpp pngs upside down and skewed others (alpha tucan.png )
' 6. Ver.0 didn't use advanced APIs like Msimg32.dll if available
'    This version will use them for reading/displaying if possible unless overridden
'    Thus should be faster displaying when system has access to those DLLs
'    Win98 & above can use 32bpp alpha bitmaps & AlphaBlend via Msimg32.dll
'    WinNT4 & lower are screwed: per pixel manual alphablending is required
' 7. Ver.0 automatically assumed the hardware was little endian
'    Now using ws2_32.dll to convert endians if needed (some pcs are compatible with both)
' 8. Ver.0 assumed chunk names would equate to US ASCII characters when read from file.
'    Now using the numerical equivalent of the chunk names
' 9. Ver.0 did not offer CRC checks. Now, by default, critical chunks are CRC checked
'    and non-critical are optional. Using zLib to create CRC codes
' 10. Ver.0 did not handle known png errors. For example, per png specs:
'    http://www.w3.org/TR/PNG/#5ChunkOrdering
'    "When present, the tRNS chunk must precede the first IDAT chunk,
'          and must follow the PLTE chunk, if any.
' 11. Ver.0 didn't recognize all known chunk names
' 12. Tweaked areas that could be optimized. For example, the Ver.0 read the
'    8 byte signature and checked each byte (1 Read & 8 IF statements).
'    Modified to cache the signature & uses only 2 reads and 2 IF statement
' 13. Ver.0 didn't offer ability to StretchBlt, tricky when using transparency
' 14. Reworked many routines to prove to myself I understood what was happening.
'    Majority of routines are now commented and organized.

' // LaVolpe, Dec 1 thru 10
' KNOWN ISSUES WITH THIS PROJECT
' 1. Does not use all chunks when displaying an image. Should you know how to
' use these chunks, please update project and repost or email me so I can
' update the posting. The following chunks are not handled at this time,
' simply cause I don't know 100% for sure how to handle them.
' - cHRM - Primary chromaticities and white point
' - oFFs - Image Offset, primarily used for printing; but only for printing?
' - pCAL - Pixel Calibration
' - sCAL - Physical Scale
' - pHYs - Physical Pixel Dimensions
' - sRGB - sRGB color space as defined by the International Color Consortium
' - gAMA - relationship between the image & the desired display output intensity
' - sBIT - Significant bits & bit depth enforcement
' - hIST - Palette histogram
' - iTXt - International Text Annotations (unicode)
' - gIFg - GIF Conversion Info
' - gIFx - GIF Conversion Info
' - iCCP - Embedded ICC profile
' - sPLT - Suggested Palette
' - fRAc - Fractal Parameters
' 2. Not positive all my color routines are best; afterall, I am color blind

' For 48bpp (2.8 trillion colors) images I am simply selecting the 1st of the
' two bytes provided; not totally confident it should be handled that way.
' Playing with small 48bpp pngs, I have seen a difference as much as 100 between
' the two bytes; however, averaging the two requires more calculations per pixel
' and didn't look good IMO. Like scaling down 24bpp to 8bpp, color loss would be
' expected, so would scaling 48bpp to 24bpp. But is there a better way than
' averaging or just picking one of the two provided bytes?
' BTW 48bpp could be a 24bpp bitmap with 2 planes vs 1. As MSDN says the bmpinfo
' header .bmPlanes member cannot be other than one, I am assuming scaling is required
' and true 48bpp bitmaps with current APIs is not possible.
' 3. Per PNG specs, the width & height of an image can be Long values. This is not possible
' for usage of API Bitmaps. The .biDataSize member of the BitmapInfoHeader is a Long
' value & calculating (2^31-1)width * (2^31-1)height will be an overflow. To be safe,
' the routines are limiting total width and/or height to <= 46,000 or w*h <= 2.116gb
' Additionally, array/memory pointers are Long values, and image sizes beyond those
' max values will cause an overflow on the pointers as they are moved along the arrays.
' 4. VB5 users: Look for Replace$() calls or other non-VB5 friendly calls & modify as needed
'          Also replace following line:
'    Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
'          with
'    Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long
' 5. Requires the zlib.dll dependency. See ZLIB.DLL REQUIREMENT...
' zip file containing VB-ready DLL: http://www.winimage.com/zLibDll/zlib123dll.zip
' The above URL is for the zip; the webpage is http://www.winimage.com/zLibDll/
' IMPORTANT: Rename the dll to zlibVB.dll & place in your system32 folder; no registration required

'--------------------------------------------------------------------------------------
' TODO:
' 1. Finish parsing chunks where 100% confident can at least parse. These can be passed
' to user via properties like the sRGB & cHRM chunks currently are
' 2. Process Unknown/Private chunks into array and provide thru a property/function
' Although these are non-standard, they might mean something to the owner of the PNG
' 3. Prevent unauthorized chunks from being passed at all. These are UCase chunks
' that are not IEND, IHDR or IDAT. UCase names are reserved and cannot be private
' 4. Should keep track of which chunk came first. This info can be used to determine
' invalid chunk order and also if PNG modified and rewritten, which chunks get
' saved in which order. There is documentation on this process in the PNG specs
' 5. Finish writing needed code to use class in Win95/NT4 & below
' Will be slower but at least doable and will make class all O/S friendly
' 6. The PNG Writer -- get it finalized & tested.
'--------------------------------------------------------------------------------------

' zLIB (v1.2.3) calls, needed to compress/decompress png data
' ///////////// ZLIB.DLL REQUIREMENT \\\\\\\\\\\\
' not all calls are used yet and are validated via ValidateDLLExists function
Private Declare Function Zcompress Lib "zlibVB.dll" Alias "compress" (ByRef Dest As Any, ByRef destLen As Long, ByRef Source As Any, ByVal sourceLen As Long) As Long
Private Declare Function ZcompressBound Lib "zlibVB.dll" Alias "compressBound" (ByVal sourceLen As Long) As Long
Private Declare Function Zuncompress Lib "zlibVB.dll" Alias "uncompress" (ByRef Dest As Any, ByRef destLen As Long, ByRef Source As Any, ByVal sourceLen As Long) As Long
Private Declare Function Zadler32 Lib "zlibVB.dll" Alias "adler32" (ByVal adler As Long, ByRef buf As Any, ByVal Length As Long) As Long
Private Declare Function Zcrc32 Lib "zlibVB.dll" Alias "crc32" (ByVal crc As Long, ByRef buf As Any, ByVal Length As Long) As Long
Private Declare Function Zcompress2 Lib "zlibVB.dll" Alias "compress2" (ByRef Dest As Any, ByRef destLen As Long, ByRef Source As Any, ByVal sourceLen As Long, ByVal level As Long) As Long
Private Const Z_OK As Long = &H0
Private Const Z_NO_COMPRESSION As Long = 0
Private Const Z_BEST_SPEED As Long = 1
Private Const Z_BEST_COMPRESSION As Long = 9
Private Const Z_DEFAULT_COMPRESSION As Long = (-1)

' This next Event is fired after the PNG image is loaded and just before it is about
' to be processed/painted. Use this event to resize your DC if needed, change background
' colors, and change other options as needed (i.e., prevent transparencies)

tmtony · 发表于 2015-6-27 19:35:07

' If you are simply loading the PNG file and will call this class's Paint method
' after the PNG has been fully processed, do not respond to this event. This event
' is used only for progressive displaying image while simultaneously loading it
' Limitation: Progressive display not available if image needs to be stretched
' ^^ if this applies, Paint the image after it is completely processed
Public Event ProgessiveDisplay(ByVal Width As Long, ByVal Height As Long, _
      ByRef destinationDC As Long, ByRef destinationHwnd As Long, _
      ByVal WinBkgColor As Long, ByVal AlphaPng As Boolean, _
      ByRef X As Long, ByRef Y As Long, _
      ByVal IsInterlaced As Boolean, ByVal useProgression As Boolean)
' Width, Height are the actual dimensions of the PNG file
' WinBkgColor is the window color suggested in the PNG, -1 indicates no color suggested
' destinationDC is by reference so you can provide the DC to for progressive display
' destinationHwnd is by reference so you can provide the hWnd to refresh during display
' AlphaPng is true if the PNG uses transparency
' X,Y are DC coordinates to being progressive displaying
' IsInterlaced indicates whether encoded PNG is interlaced or not
' useProgression is suggested & is True under the 2 circumstances:
' - Image is Interlaced
' - Image is not interlaced & Width*Height > (Screen Width*Height)\3

' This next Event is fired while the PNG file is being processed but after it is read
Public Event Progress(ByVal Percentage As Long)
' The Percentage parameter will be a number between 0 and 100,
' where 100 occurs when the PNG file is completely processed & just before this
' class's LoadFile method returns. Very large (screen size) images can take multiple
' seconds to load and you can provide your user a progress meter. Suggest employing
' that option whenever an image more than 1/2 the total screen size is being loaded.
' However if progressive display is being used, that in itself, is a visual progress meter.

' Following ws2_32 DLL is validated via ValidateDLLExists function
' used to convert network ordered bytes to system ordered bytes (big/little endian)
Private Declare Function ntohl Lib "ws2_32.dll" (ByVal netlong As Long) As Long
Private Declare Function ntohs Lib "ws2_32.dll" (ByVal netshort As Integer) As Integer
' used to convert system ordered bytes to network ordered bytes
Private Declare Function htonl Lib "ws2_32.dll" (ByVal hostlong As Long) As Long
Private Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As Integer) As Integer

Private Declare Function GetPixel Lib "gdi32.dll" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (ByRef Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
Private Declare Function GetSysColor Lib "user32.dll" (ByVal nIndex As Long) As Long 'also used in clsBarColors
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long

' change to msvbbm50.dll for VB5 projects
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
' array mapping structures
Private Type SafeArrayBound
cElements As Long
lLbound As Long
End Type
Private Type SafeArray1D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
rgSABound As SafeArrayBound
End Type

' following are the actual PNG image properties, exposed via class properties
' (**)Not all are translated until called from the appropriate class property
Private png_Width As Long                ' image width
Private png_Height As Long             ' image height
Private png_BitDepth As Byte             ' image bit depth/count: 1,2,4,8,16
Private png_ColorType As Byte          ' image color type: 0,2,3,4,6
Private png_Interlacing As Byte          ' interlaced: 0,1
Private png_WinBKG As Long             ' suggested window background color
Private png_Gamma As Long                ' gamma correction value * 10000
Private png_Palette() As Byte          ' image palette information
Private png_TransSimple() As Byte       ' image simple transparency information
Private png_Chromaticity() As Long       ' image Chromaticity information(**)
Private png_Physical() As Long          ' image aspect ratio/pixel size information(**)
Private png_Offsets() As Long          ' image physical offset information(**)
Private png_Comments() As Byte          ' unprocessed text chunks within png file(**)
Private png_LastModified() As Byte       ' date in 7-byte format(**)
Private png_sRGB As Byte                ' standard RGB color space: 0,1,2,3

' following are class options/settings.
Private c_Overrides As Integer ' compilation of all options in 1 variable vs checking multiple variables
' 1=no progressive display, 2=proDisplay/Fade, 4=proDisplay/Pixelated
' 8=ProDisplay/Scanner, 16=ForceNoAlpha, 32=Force32Bit
' 2048=class busy/prevent access to functions
' 4096=class locked/prevent access to everything until PNG finished processing
Private c_TransColor As Long  ' translated simple transparency color (BGR or index value)
Private c_DisposableDC As Boolean ' 0=keep DC;1=destroy DC after PNG processed
Private c_ClassValidated As Boolean ' indicates if required DLLs are present
Private c_InterlaceOption As Byte ' enumPgDsply value
Public Enum enumPgDsply
[pngPixelated] = 8
pngAuto = 0
'^^ Alpha Interlaced images are Fade-In, Non-Alpha interlace are pixelated,
' non-interlaced is dependent on size of image
pngFadeIn = 1 ' for non-alpha interlaced pngs
pngScanner = 2 ' applies for all non-interlaced images regardless of overall size
pngNeverProgressive = 4 ' no progressive display ever; consider a custom progress meter
End Enum
Private c_AlphaBkg As Long    ' enumAlphaBkg value
Private c_AlphaColor As Long ' translated color based off of c_AlphaBkg value
Public Enum enumAlphaBkg
alphaTransparent = -1
alphaNoBkgNoAlpha = -2
alphaTransColorBkg = -3
alphaPNGwindowBkg = -4
End Enum

' constants used to make reading c_Overrides easier
Private Const pdNoInterlace As Integer = 1
Private Const pdFadeIn As Integer = 2
Private Const pdPixelated As Integer = 4
Private Const pdScanner As Integer = 8
Private Const pdNoAlpha As Integer = 16
Private Const pd32bit As Integer = 32
' 64,128,256,512,1024 ' reserved as needed
Private Const pdBUSY As Integer = 2047 ' << purposely off by 1
Private Const pdLocked As Integer = 4096

' matrix/lookup tables
Private pow2x8() As Byte ' a look up table for bit shifting (1,2,4 bit pixels)
' arrays to help process interlacing more quickly & are in relation to the 8x8 matrix
Private MatrixRow() As Byte    ' row where each pass starts within interlace matrix
Private MatrixCol() As Byte    ' column where each pass starts within interlace matrix
Private MatrixRowAdd() As Byte ' gaps between each row withiin each pass
Private MatrixColAdd() As Byte ' gaps between each column within each pass
' following are used for progressive/pixellated display only
Private MatrixCY() As Byte       ' height of each pixel in a scanline
Private MatrixCX() As Byte       ' width of each pixel in a scanline

tmtony · 发表于 2015-6-27 19:36:03

' known PNG chunk names & their numerical equivalent
' 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_bKGD As Long = &H44474B62 'Background Color
Private Const chnk_cHRM As Long = &H4D524863 'Primary chromaticities and white point
Private Const chnk_gAMA As Long = &H414D4167 'relationship between the image & the desired display output intensity
Private Const chnk_hIST As Long = &H54534968 'Palette histogram
Private Const chnk_pHYs As Long = &H73594870 'Physical Pixel Dimensions
Private Const chnk_sBIT As Long = &H54494273 'Significant bits & bit depth enforcement
Private Const chnk_tEXt As Long = &H74584574 'Text - uncompressed
Private Const chnk_zTXt As Long = &H7458547A 'Text - compressed
Private Const chnk_tIME As Long = &H454D4974 'Timestamp
Private Const chnk_tRNS As Long = &H534E5274 'Simple Transparency
' http://www.libpng.org/pub/png/png-sitemap.html
Private Const chnk_sRGB As Long = &H42475273 'RGB color space as defined by the International Color Consortium
Private Const chnk_iCCP As Long = &H50434369 'Embedded ICC profile
Private Const chnk_sPLT As Long = &H544C5073 'Suggested Palette
Private Const chnk_iTXt As Long = &H74585469 'International Text Annotations (unicode)
Private Const chnk_oFFs As Long = &H7346466F 'Image Offset, primary used for printing
Private Const chnk_pCAL As Long = &H4C414370 'Pixel Calibration
Private Const chnk_sCAL As Long = &H4C414373 'Physical Scale
Private Const chnk_gIFg As Long = &H67464967 'GIF Conversion Info
Private Const chnk_gIFx As Long = &H78464967 'GIF Conversion Info
Private Const chnk_fRAc As Long = &H63415266 'Fractal Parameters

Private cPNGimage As stdPNGdata ' PNG|Bitmap Render class

Public Function LoadFile(ByVal Filename As String, _
         Optional ByVal ValidateAllData As Boolean = True, _
         Optional ByVal Make32Bit As Boolean = False, _
         Optional ByVal AlphaBlendValue As Byte = 255) As Boolean

' FileName is the full path & filename of the PNG to load/display
' ValidateAllData is True to validate all PNG data, else only critical data is validated
' Make32Bit if True will force PNG to 32bpp BMP. Needed for alphablending if desired
' AlphaBlendValue is from 0-255 and will blend the final result into a DC
' when progressively displaying PNG.

If c_ClassValidated = False Then
      If ValidateDLLExists = False Then Exit Function
      c_ClassValidated = True
End If

If c_Overrides > pdBUSY Then Exit Function ' prevent recursion from the Progress event

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

Dim ptrLoc As Long       ' used to ensure parsing doesn't go past EOF of corrupted file
Dim Filenumber As Long    ' the file handle
Dim gpLong As Long       ' general purpose long value
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 CRC32value As Long    ' CRC value of the chunk

Dim ChunkBytes() As Byte ' current chunk's bytes
Dim RawPNGdata() As Byte ' uncompressed png data
Dim IDATdata() As Byte    ' compressed png data

Dim cName(3) As Byte       ' for debugging purposes only

Dim uncmprssSize As Long ' calculated size of uncompressed PNG data
Dim strErrorMsg As String ' crtical error message
Dim doValidate As Long    ' optional value to CRC check all data

' reset some stuff
ClearMemoryVariables

' attempt to open the file with read access
On Error Resume Next
Filenumber = FreeFile
Open Filename For Binary Access Read As Filenumber
If Err Then
      MsgBox Err.Description, vbExclamation + vbOKOnly, "Error Accessing File"
      Close #Filenumber
      Err.Clear
      Exit Function
End If
On Error GoTo 0

' validate we are looking at a png file
If LOF(Filenumber) > 56 Then ' minimal (signature=8;header=13,3 rqd chunks=36 min)
      Get Filenumber, , gpLong '  ^^ 3 rqd? IHDR, IEND, & at least 1 IDAT
      If gpLong = png_Signature1 Then
         Get Filenumber, , gpLong
         If gpLong = png_Signature2 Then ptrLoc = 8  ' set pointer to current file position
      End If
End If

If ptrLoc = 0 Then ' we have an invalid PNG file
      Close #Filenumber
      MsgBox "This is not a valid PNG file", vbExclamation + vbOKOnly, "Invalid Format"
      Exit Function
End If

doValidate = Abs(ValidateAllData)
ReDim IDATdata(lenIDAT)

Do ' read & pre-process the png file

      Get Filenumber, , gpLong ' number of bytes for the chunk
      ChunkLen = ntohl(gpLong) ' longs are big endian, need little endian for Windows

      ' track position of pointer in the file
      ptrLoc = ptrLoc + ChunkLen + 12 ' 12 = 4byte name + 4byte CRC + 4byte chunk count
      If ptrLoc > LOF(Filenumber) Then
         ' corrupted file; abort
         Close #Filenumber
         MsgBox "This PNG file is corrupted", vbExclamation + vbOKOnly, "Corrupted File"
         Exit Function
      End If

tmtony · 发表于 2015-6-27 19:36:51

' read chunk name & chunk data, read CRC separately
      ReDim ChunkBytes(0 To ChunkLen + 3)
      Get Filenumber, , ChunkBytes
      CopyMemory ChunkName, ChunkBytes(0), &H4 ' extract the chunk name
      Get Filenumber, , CRC32value          ' read the CRC value (big endian)

      If ChunkLen < 1 Then
         ' should never be <0; however can be zero at anytime
         If ChunkName = chnk_IEND Then Exit Do
         ' TODO: get this out of its own IF statement...Make routines handle it
         Debug.Print "zero length chunk: &H"; Hex(ChunkName) ' debugging
      Else

         ' each of the chunk parsing routines will be in a separate function.
         ' This is so that they can easily be modified without affecting any
         ' of the other code. Additionally, it is possible that chunk types will
         ' increase as PNG continues to evolve. Except IDAT, all chunks
         ' are in their own routines; even sRGB which is only a 1 byte chunk.
         Select Case ChunkName

         Case chnk_IDAT ' UCase chunk names are critical - CRC check
            ' compressed, filtered image data
            On Error Resume Next
            ' error? what error? all precautions taken in zChunk_IHDR function
            ' However; no predicting "Out of Memory" errors
            If ntohl(CRC32value) = Zcrc32(0, ChunkBytes(0), ChunkLen + 4) Then
                  ReDim Preserve IDATdata(lenIDAT + ChunkLen - 1)
                  CopyMemory IDATdata(lenIDAT), ChunkBytes(4), ChunkLen
                  lenIDAT = UBound(IDATdata) + 1
            Else ' error; CRC validation failed; corrupt file
                  strErrorMsg = "Corrupted Image Data (bad CRC). Cannot continue."
                  Exit Do
            End If
            If Err Then
                  strErrorMsg = "Failed to extract image data. Cannot continue."
                  Exit Do
            End If
            On Error GoTo 0

         Case chnk_PLTE ' UCase chunk names are critical - CRC check
            strErrorMsg = zChunk_PLTE(ChunkBytes(), ChunkLen, CRC32value)
            If Len(strErrorMsg) Then Exit Do

         Case chnk_bKGD ' suggested window background color
            strErrorMsg = zChunk_bKGD(ChunkBytes(), ChunkLen, CRC32value * doValidate)
            If Len(strErrorMsg) Then Exit Do

         Case chnk_tEXt, chnk_zTXt 'uncompressed/compressed text
            strErrorMsg = zChunk_tEXt(ChunkBytes(), ChunkLen, CRC32value * doValidate)
            If Len(strErrorMsg) Then Exit Do

         Case chnk_tIME ' image last modified timestamp
            strErrorMsg = zChunk_tIME(ChunkBytes(), ChunkLen, CRC32value * doValidate)
            If Len(strErrorMsg) Then Exit Do

         Case chnk_tRNS ' simple transparency option
            ' CRC checked 'cause if invalid, we could generate an out of bounds
            ' error in one of the other routines that reference this array
            strErrorMsg = zChunk_tRNS(ChunkBytes(), ChunkLen, CRC32value)
            If Len(strErrorMsg) Then Exit Do

         Case chnk_IHDR ' UCase chunk names are critical - CRC check
            strErrorMsg = zChunk_IHDR(ChunkBytes(), ChunkLen, CRC32value, uncmprssSize)
            If Len(strErrorMsg) Then Exit Do

         Case chnk_IEND ' UCase chunk names are critical - CRC check
            ' should CRC check for corrupted file; but why? we're at end of image
            Exit Do

         '//////////////////////////////////////
         '/ unhandled chunks, but valid chunks /
         '//////////////////////////////////////
         ' Following have not been programmed into
         ' PNG>BMP conversion/display if required

         ' all chunks below are also non-critical; therefore, if they fail to be
         ' translated/crc checked, no biggie: It may affect image quality, but
         ' won't affect whether or not the image can be displayed.
         Case chnk_pHYs
            Call zChunk_pHYs(ChunkBytes(), ChunkLen, CRC32value * doValidate)
         Case chnk_gAMA
            Call zChunk_gAMA(ChunkBytes(), ChunkLen, CRC32value * doValidate)
         Case chnk_cHRM
            Call zChunk_cHRM(ChunkBytes(), ChunkLen, CRC32value * doValidate)
         Case chnk_oFFs
            Call zChunk_oFFs(ChunkBytes(), ChunkLen, CRC32value * doValidate)
         Case chnk_sRGB
            Call zChunk_sRGB(ChunkBytes(), ChunkLen, CRC32value * doValidate)


         Case chnk_sBIT, chnk_hIST, chnk_iTXt, chnk_pCAL
            CopyMemory cName(0), ChunkName, &H4
            Debug.Print "unprocessed known chunk "; StrConv(cName, vbUnicode)
         Case chnk_iCCP, chnk_sPLT, chnk_fRAc
            CopyMemory cName(0), ChunkName, &H4
            Debug.Print "unprocessed known chunk "; StrConv(cName, vbUnicode)
         Case chnk_sCAL, chnk_gIFg, chnk_gIFx
            CopyMemory cName(0), ChunkName, &H4
            Debug.Print "unprocessed known chunk "; StrConv(cName, vbUnicode)

         Case Else
            ' unknown chunks, custom/user-defined chunks?
            ' ToDo: cache & make available via a property or public event
            CopyMemory cName(0), ChunkName, &H4
            Debug.Print "UNKNOWN CHUNK!!! "; StrConv(cName, vbUnicode)
         End Select

      End If

Loop

Close #Filenumber

If lenIDAT = 0 Or Len(strErrorMsg) > 0 Then  ' invalid png image
      If Len(strErrorMsg) = 0 Then strErrorMsg = "No image data found. Cannot continue."
      If Err Then Err.Clear
      MsgBox strErrorMsg, vbExclamation + vbOKOnly, "Invalid PNG Format"
      ClearMemoryVariables
      Exit Function
End If

c_Overrides = pdBUSY + 1 ' allows reading/writing properties but no functions
RaiseEvent Progress(0) ' inform user we started the process

On Error Resume Next
' we need to uncompress our PNG file
ReDim RawPNGdata(0 To uncmprssSize - 1)
gpLong = Zuncompress(RawPNGdata(0), uncmprssSize, IDATdata(0), UBound(IDATdata) + 1)
If gpLong <> 0 Then
      ' failed to uncompress & shouldn't happen 'cause if I calculated uncmprssSize
      ' wrong, then other calculations in this routine are wrong too
      ' See: CalcUncompressedWidth
      MsgBox "This PNG file is not compressed correctly.", vbOKOnly + vbExclamation, "Invalid Format"
      ClearMemoryVariables
      Exit Function
End If

' here we will inform the user that the PNG file is ready. Since the user may
' choose to set optional settings that will have an effect on the type of bitmap
' we will use to convert the PNG to, we need that info before continuing...

Dim dBitPP As Byte
Dim tgtWindow As Long, tgtDC As Long
Dim dcX As Long, dcY As Long

If c_InterlaceOption < pngNeverProgressive Then
      ' if user didn't prohibit progressive display, send request
      RaiseEvent ProgessiveDisplay(png_Width, png_Height, tgtDC, tgtWindow, _
            png_WinBKG, (png_ColorType > 3 Or c_TransColor > -1), dcX, dcY, (png_Interlacing = 1), CalculateOverrides(0, 0, True))
End If

' combine all known options into a single variable. Lock options into place
CalculateOverrides tgtDC, tgtWindow, False
If Make32Bit = True Or AlphaBlendValue < 255 Then c_Overrides = c_Overrides Or pd32bit

' tweak some settings to ensure correct bmp representations are performed
GetDepthInfo dBitPP, 0, 0, 0 ' determine the bit count needed for our bitmap
If dBitPP = 4 And png_BitDepth = 2 Then
      If IsArrayEmpty(Not png_Palette) Then
      ' special case here for conversion btwn 2bpp(4 color) to 4bpp(8 color)...
      ' The stdPNGdata class will create an 8-color grayscale palette for 4bpp images.
      ' But when we convert from 2bpp to 4bpp, we don't want an 8-color palette,
      ' therefore, we create the 4-color palette now, if needed:
         ' grayscale will be used; create the palette
         ReDim png_Palette(0 To 11)             ' 1st entry is 0/black
         CopyMemory png_Palette(3), 5592405, &H3  ' rgb(85,85,85)
         CopyMemory png_Palette(6), 11184810, &H3 ' rgb(170,170,170)
         CopyMemory png_Palette(9), vbWhite, &H3  ' rgb(255,255,255)
      End If
End If

tmtony · 发表于 2015-6-27 19:37:11

Set cPNGimage = New stdPNGdata

' here we create the resources needed to convert the PNG file
If cPNGimage.CreateBitmapBase(dBitPP, png_Width, png_Height, png_Palette(), tgtDC) = False Then
      MsgBox "Resources may be too low, cannot create necessary drawing objects.", vbExclamation + vbOKOnly
      ClearMemoryVariables
      Exit Function
Else
      ' see if we need any additional resources to display the bitmap
      ' only needed if progressively displaying an image
      If (c_Overrides And pdNoInterlace) = 0 Or c_AlphaColor > -1 Then
         If (dBitPP = 32 Or png_Interlacing = 1 Or c_AlphaColor > -1) Then ' alpha and/or interlacing
            ' will be drawing to a DC, but other resources only needed in some cases
            If cPNGimage.CreateWorkSpace(tgtDC, dcX, dcY, (png_Interlacing = 1), c_AlphaColor) = False Then c_Overrides = c_Overrides Or pdNoInterlace
            ' if memory resources low & failed to create needed resources to
            ' progressively display PNG, don't progressively display
         End If
      End If

      ' call function to begin converting PNG to Bitmap
      If png_Interlacing = 0 Then
         gpLong = UnfilterNI(RawPNGdata(), tgtDC, tgtWindow, dcX, dcY, AlphaBlendValue)
      Else
         gpLong = UnfilterInterlaced(RawPNGdata(), tgtDC, tgtWindow, dcX, dcY, AlphaBlendValue)
      End If
End If

' return results
If gpLong = 0 Then
      MsgBox "Failed to properly read PNG image data.", vbExclamation + vbOKOnly, "Invalid Format"
      ClearMemoryVariables
Else
      If c_AlphaColor > -1 Then cPNGimage.UseWorkingCopy AlphaBlendValue

      If (tgtDC <> 0 And tgtWindow <> 0) Then
         c_Overrides = c_Overrides And Not pdLocked
         ' couldn't create the needed workspace to progressively display PNG
         ' or user chose progressive display for non-interlaced but prevented
         ' non-interlaced images from being progressively displayed...
         ' But user is expecting progressive display. The PNG is
         ' now completely processed, so paint it & then refresh the DC
         If (c_Overrides And pdNoInterlace) = pdNoInterlace Or (c_Overrides And 15) = 0 Then
            cPNGimage.DrawToDC tgtDC, dcX, dcY, png_Width, png_Height, 0, 0, png_Width, png_Height, 0, AlphaBlendValue, tgtWindow
         End If
      End If
      LoadFile = True
      If c_DisposableDC Then cPNGimage.ManageDC = False
End If

c_Overrides = 0

End Function

Public Sub Paint(ByVal hDC As Long, ByVal destX As Long, ByVal destY As Long, _
         Optional destCx As Long, Optional destCy As Long, _
         Optional PngDC As Long, Optional pngX As Long, Optional pngY As Long, _
         Optional pngCx As Long, Optional pngCy As Long, Optional AlphaBlend As Byte = 255)

If c_Overrides > pdBUSY Then Exit Sub ' prevent recursion from the Progress event
' basically a StretchBlt-type call
' The AlphaBlend value is ignored if the converted PNG is < 32bpp
If Not cPNGimage Is Nothing Then
      cPNGimage.DrawToDC hDC, destX, destY, destCx, destCy, pngX, pngY, pngCx, pngCy, PngDC, AlphaBlend
End If

End Sub

Public Property Get Handle() As Long
' the converted PNG's BMP handle
If c_Overrides < pdLocked Then ' prevent recursion from the Progress event
      If Not cPNGimage Is Nothing Then Handle = cPNGimage.PngHandle
End If
End Property
Public Property Get hDC() As Long
' the DC managed by this class. If hasOwnDC=False then no DC handle is returned
If c_Overrides < pdLocked Then
      If Not cPNGimage Is Nothing Then hDC = cPNGimage.PngDC
End If
End Property

Public Property Get HasOwnDC() As Boolean
' Determines whether or not the class will keep a DC in memory
' prevent recursion from the Progress event
If c_Overrides < pdLocked Then HasOwnDC = Not c_DisposableDC
End Property

Public Property Let HasOwnDC(bCreateDC As Boolean)
If c_Overrides < pdLocked Then ' prevent recursion from the Progress event
      c_DisposableDC = Not bCreateDC
      If Not cPNGimage Is Nothing Then cPNGimage.ManageDC = bCreateDC
End If
End Property

Public Property Get Height() As Long
' the PNG's actual height & will also be the converted BMP's height
' prevent recursion from the Progress event
If c_Overrides < pdLocked Then Height = png_Height
End Property

Public Property Get LastModified() As Date
' the Last Modified timestamp if PNG provided one
If c_Overrides < pdLocked Then ' prevent recursion from the Progress event
      If Not IsArrayEmpty(Not png_LastModified) Then
         On Error Resume Next
         Dim iYear As Integer, lDate As Date, lTime As Date
         CopyMemory iYear, png_LastModified(0), 2
         If iYear Then
            ' don't be tempted to combine lines. Doing so is producing error:
            ' Expression too complex. This is only way I can get it to not error out
            lDate = DateSerial(iYear, png_LastModified(2), png_LastModified(3))
            lTime = TimeSerial(png_LastModified(4), png_LastModified(5), png_LastModified(6))
            LastModified = lDate + lTime
         End If
         If Err Then Err.Clear
      End If
End If
End Property

Public Property Get TransparentStyle() As enumAlphaBkg
' Option to set the background color for transparent pixels
' Any option other than alphaTransparent destroys any transparency
' information within the converted BMP which will be 24bpp

' prevent recursion from the Progress event
If c_Overrides < pdLocked Then TransparentStyle = c_AlphaBkg
End Property

Public Property Let TransparentStyle(BkgStyle As enumAlphaBkg)
If c_Overrides < pdLocked Then c_AlphaBkg = BkgStyle
' prevent recursion from the Progress event
End Property

Public Property Get GammaCorrection() As Double
' returns the Gamma value if PNG provided one
' Note: use 1/GammaCorrection to display values like 2.2, 1.8, etc
If c_Overrides < pdLocked Then ' prevent recursion from the Progress event
      On Error Resume Next
      GammaCorrection = png_Gamma / 100000
      If Err Then Err.Clear
End If
End Property

Public Property Get Chromaticity() As Double()
' returns Chromaticity information if PNG provided it. The Doubles are translated as:
' a return array with UBound<0 means not provided
'ArrayItem(0) is White X point
'ArrayItem(1) is White Y point
'ArrayItem(2) is Red X point
'ArrayItem(3) is Red Y point
'ArrayItem(4) is Green X point
'ArrayItem(5) is Green Y point
'ArrayItem(6) is Blue X point
'ArrayItem(7) is Blue Y point
Dim dRtn() As Double, I As Integer
ReDim dRtn(-1 To -1) ' default return array
If c_Overrides < pdLocked Then ' prevent recursion from the Progress event
      On Error Resume Next
      If Not IsArrayEmpty(Not png_Chromaticity) Then
         ReDim dRtn(0 To 7)
         For I = 0 To 7
            dRtn(I) = png_Chromaticity(I) / 100000
         Next
      End If
      If Err Then Err.Clear
End If
Chromaticity = dRtn
End Property

Public Property Get AspectRatio() As Long()
' Returns data used for pixel size if PNG provides it. The Longs are translated as:
'ArrayItem(0) is the X ratio
'ArrayItem(1) is the Y ratio
'ArrayItem(2) is either 0=Unknown Measurement, 1=Meters where 1 inch=0.0254 meters
Dim lRtn() As Long
ReDim lRtn(-1 To -1)
If c_Overrides < pdLocked Then ' prevent recursion from the Progress event
      On Error Resume Next
      If Not IsArrayEmpty(Not png_Physical) Then lRtn() = png_Physical()
      If Err Then Err.Clear
End If
AspectRatio = lRtn
End Property

tmtony · 发表于 2015-6-27 19:37:54

Public Property Get Offsets() As Long()
' returns information for Page/Display Offsets if PNG provides it
' The Longs are translated as
' ArrayItem(0) is the X offset
' ArrayItem(1) is the Y offset
' ArrayItem(2) is either 0=Pixels, or 1=Microns
Dim lRtn() As Long
ReDim lRtn(-1 To -1)
If c_Overrides < pdLocked Then ' prevent recursion from the Progress event
      On Error Resume Next
      If Not IsArrayEmpty(Not png_Offsets) Then lRtn() = png_Offsets()
      If Err Then Err.Clear
End If
Offsets = lRtn
End Property

Public Property Get ScanLineWidth() As Long
' the converted BMP's DWord aligned ScanLine Width.
' The total byte size for the BMP is ScanLineWidth*Height
' prevent recursion from the Progress event
If c_Overrides < pdLocked Then
   If Not cPNGimage Is Nothing Then ScanLineWidth = cPNGimage.PngDataSize \ png_Height
End If
End Property

Public Property Get StdRGB() As Byte
' Returns whether or not Image should be displayed using Standard RGB (sRGB)
' Possible values are
' 0 = the information is not provided
' 1 = Perceptual
' 2 = Relative Colorimetric
' 3 = Saturation
' 4 = Absolute Colorimetric
' prevent recursion from the Progress event
If c_Overrides < pdLocked Then StdRGB = png_sRGB
End Property

Public Property Get Width() As Long
' the PNG's actual width & will also be the converted BMP's width
' prevent recursion from the Progress event
If c_Overrides < pdLocked Then Width = png_Width
End Property

Public Property Get Comments(Optional sNoCommentPrefix As String) As String
' Returns embedded comments if PNG provided them
' the Optional sNoCommentPrefix will be returned if no comments were provided
If c_Overrides < pdLocked Then ' prevent recursion from the Progress event
      Comments = ExtractText
      If Comments = "" Then Comments = sNoCommentPrefix
End If
End Property

Public Property Get Palette() As Byte()
' Returns the current palette used by the PNG, if any
' The palette is in RGB order with one byte for each R,G, & B
' The number of palette entries will be evenly divisible by 3
' A UBound return array of -1 indicates no palette is applicable

Dim rtnPalette() As Byte, pIndex As Long, stepVal As Long, nrColors As Long
ReDim rtnPalette(-1 To -1)

If c_Overrides < pdLocked Then ' prevent recursion from the Progress event
      On Error Resume Next
      If Not IsArrayEmpty(Not png_Palette) Then
         rtnPalette() = png_Palette
      Else
         If png_ColorType = 0 Then ' grayscale with implied palette
            If png_BitDepth = 16 Then
                  nrColors = 255    ' ubound of palette entries
            Else
                  nrColors = pow2x8(png_BitDepth) - 1 ' ubound of palette entries
            End If
            ReDim rtnPalette(0 To (nrColors * 3 + 2))  ' each are R,G,B
            stepVal = 255 \ nrColors
            For pIndex = 1 To nrColors
                  ' palette entry zero is always RGB(0,0,0)
                  rtnPalette(pIndex * 3) = pIndex * stepVal
                  rtnPalette(pIndex * 3 + 1) = pIndex * stepVal
                  rtnPalette(pIndex * 3 + 2) = pIndex * stepVal
            Next
         End If
      End If
      If Err Then Err.Clear
End If
Palette = rtnPalette()
End Property
Public Property Let Palette(newPalette() As Byte)
' CAUTION** NOT FULLY TESTED

' note that a paletted 16bpp PNG is still 8 bytes per R,G,B element
' PNG palettes are always R,G,B triples each having 1 byte per R,G,B element

' You should check the ColorType property before calling this function....
' The following ColorType will have a palette
' ColorType of 3, no other color type will have a palette
' However, ColorType of 0 has an implied grayscale palette although it
' doesn't exist. This doesn't mean you can't override the palette by
' providing one here.  Doing so will have the routine tweak the ColorType
' to be 3 vs 0, so that the colors will be read from the palette you provided.
' You should ensure that the passed palette is arrayed (0 To (2^bitcount)*3-1).
' Keep in mind that a 16bpp image is considered 8bpp for palette entries.

' Providing a null palette will force the routine to use grayscale values

If c_Overrides >= pdLocked Then Exit Property

On Error Resume Next
Dim nrColors As Long, maxEntries As Long, pIndex As Long

If png_ColorType = 0 Then ' grayscale

      If Not IsArrayEmpty(Not newPalette) Then
         If LBound(newPalette) Then Exit Property ' must be zero bound

         ' user supplied a palette for a color type that
         ' isn't allowed palettes; convert to paletted PNG
         png_ColorType = 3 ' paletted
         ' to ensure no out of bounds check, palette must be maxed out
         If png_BitDepth > 4 Then
            maxEntries = 256 * 3
         Else
            maxEntries = pow2x8(png_BitDepth) * 3
         End If
         ReDim png_Palette(0 To maxEntries - 1)
         nrColors = UBound(newPalette) + 1
         If nrColors > maxEntries Then nrColors = maxEntries
         CopyMemory png_Palette(0), newPalette(0), nrColors

         ' to finish converting to a ColorType 3, we need to check
         ' for simple transparency.
         If Not IsArrayEmpty(Not png_TransSimple) Then
            ' the grayscale is using simple transparency
            c_TransColor = png_TransSimple(1)
            ReDim png_TransSimple(0 To maxEntries \ 3 - 1)
            FillMemory png_TransSimple(0), maxEntries \ 3, 255
            png_TransSimple(c_TransColor) = 0
         End If
      'Else no action needed
      End If

Else

      If png_ColorType <> 3 Then Exit Property 'only other type allowed palletes

      ' user is providing a modified palette for a paletted PNG
      If IsArrayEmpty(Not newPalette) Then
         ' if the image is not using transparency, we'll simply
         ' say the PNG is now grayscale, otherwise, we'll have to
         ' supply the grayscale values
         If IsArrayEmpty(Not png_TransSimple) Then
            ' no transparency used
            png_ColorType = 0
            Erase png_Palette()
         Else
            If png_BitDepth > 4 Then
                  maxEntries = 255
            Else
                  maxEntries = pow2x8(png_BitDepth) - 1
            End If
            ReDim png_Palette(0 To (maxEntries + 1) * 3 - 1)

            For nrColors = 0 To maxEntries
                  png_Palette(pIndex) = (255 \ maxEntries) * nrColors
                  png_Palette(pIndex + 1) = png_Palette(pIndex)
                  png_Palette(pIndex + 2) = png_Palette(pIndex)
                  pIndex = pIndex + 3
            Next

         End If
      Else ' swapping palettes
         If LBound(newPalette) Then Exit Property ' must be zero bound

         If png_BitDepth > 4 Then
            maxEntries = 256 * 3
         Else
            maxEntries = pow2x8(png_BitDepth) * 3
         End If
         nrColors = (UBound(newPalette) + 1)
         If nrColors > maxEntries Then nrColors = maxEntries
         ReDim png_Palette(0 To maxEntries - 1)
         CopyMemory png_Palette(0), newPalette(0), nrColors
         ' no modifications of the simple transparency array is needed
      End If
End If ' color type checks
End Property

Public Property Get IsInterlaced() As Boolean
' Returns whether or not the PNG image is in interlaced format
' prevent recursion from the Progress event
If c_Overrides < pdLocked Then IsInterlaced = (png_Interlacing = 1)
End Property

Public Property Get ColorType() As Byte
' Returns the PNG Color Type, possible values are
' 0 = Grayscale, no physical palette but palette is implied at 2^bitDepth-1
' 2 = True Color, individual R,G,B values
' 3 = Paletted, pyhsical palette exists in R,G,B where nr colors in palette = (UBound(PaletteSize)+1)\3
' 4 = Grayscale + Alpha channel. Palette is same scenario as Color Type zero
' 6 = True Color + Alpha channel, individual R,G,B,A values
' prevent recursion from the Progress event
If c_Overrides < pdLocked Then ColorType = png_ColorType
End Property
Public Property Get BitCount_PNG() As Byte
' prevent recursion from the Progress event
If c_Overrides < pdLocked Then
      'R=red, G=green, B=Blue, P=palette index
      Select Case png_ColorType
      Case 0, 3 ' grayscale & paletted (P either 8,4,2 or 1 per Byte)
         BitCount_PNG = png_BitDepth
      Case 2 ' true color (RGB or RRGGBB)
         BitCount_PNG = png_BitDepth * 3
      Case 4 ' grayscale w/alpha channel (PA or PPAA)
         BitCount_PNG = png_BitDepth * 2
      Case 6 ' true color w/alpha channel (RGBA or RRGGBBAA)
         BitCount_PNG = png_BitDepth * 4
      End Select
End If
End Property

tmtony · 发表于 2015-6-27 19:38:42

Public Property Get BitCount_BMP() As Byte
' The bitmap created to display the PNG. User options and display options
' have a direct effect on the bitcount of that BMP

' prevent recursion from the Progress event
If c_Overrides < pdLocked Then
      If Not cPNGimage Is Nothing Then BitCount_BMP = cPNGimage.pngDataBitCount
End If
End Property

Public Property Let ProgressiveDisplay(DisplayType As enumPgDsply)
' When progressive display is used, this is the preferred defaults
' pngAuto: Let system determine progressive style:
' Interlaced Image with on alpha, then pngPixelated is used
' Interlaced Image with alpha, then pngFadeIn is used
' Non-Interlaced & W*H > (Screen W*H)\3 then pngScanner is used
If c_Overrides < pdLocked Then ' prevent recursion from the Progress event
      If DisplayType < 7 Then c_InterlaceOption = CByte(DisplayType)
End If
End Property
Public Property Get ProgressiveDisplay() As enumPgDsply
' prevent recursion from the Progress event
If c_Overrides < pdLocked Then ProgressiveDisplay = c_InterlaceOption
End Property

Private Function CalculateOverrides(tgtDC As Long, tgtWindow As Long, bPrepDisplay As Boolean) As Boolean

' Routine combines several options into a single variable that can be referenced
' throughout the PNG processing functions

If bPrepDisplay Then
      ' calculating suggestion for user whether or not to use progressive display
      If png_Interlacing = 1 Then ' image is interlaced
         CalculateOverrides = True
      Else ' not interlaced but if > 1/3 screen, suggest it be progressively displayed
         If ((png_Width \ 100) * (png_Height \ 100)) > _
            (((Screen.Width \ Screen.TwipsPerPixelX) \ 100) * _
                  ((Screen.Height \ Screen.TwipsPerPixelY) \ 100)) \ 3 Then CalculateOverrides = True
      End If

Else
      ' PNG is processed, combine user options into a single variable
      Dim tColor As Long
      c_Overrides = 0
      If tgtDC = 0 Or tgtWindow = 0 Then
         ' progressive display is not wanted for this image
         c_Overrides = pdNoInterlace
      Else ' else, it is wanted
         If png_ColorType > 3 Or c_TransColor > -1 Then ' has transparency
            If png_Interlacing = 0 Then ' not interlaced, but user wants interlaced
                  c_Overrides = pdScanner ' only option for non-interlaced images
            Else
                  c_Overrides = pdFadeIn  ' only option for alpha interlaced images
            End If
         ElseIf png_Interlacing = 1 Then ' non-alpha, interlaced
            If (c_InterlaceOption And pngFadeIn) = 0 Then ' use default (pixelated)
                  c_Overrides = pdPixelated
            Else
                  c_Overrides = pdFadeIn ' use fadein
            End If
         Else
            c_Overrides = pdScanner ' the only option for non-inerlaced images
         End If
      End If

      ' flag to indicate alpha/transparency is not used at all
      If (c_TransColor < 0 And png_ColorType < 4) Then
         c_Overrides = c_Overrides Or pdNoAlpha
      Else
         ' now for alternate transparency color (user-defined)
         Select Case c_AlphaBkg
         Case alphaTransparent: ' no alternate color
         Case alphaNoBkgNoAlpha:
            c_Overrides = c_Overrides Or pdNoAlpha
         Case alphaPNGwindowBkg
            c_AlphaColor = png_WinBKG
            If c_AlphaColor < 0 Then c_AlphaColor = vbWhite
         Case alphaTransColorBkg, alphaPNGwindowBkg
            Select Case png_ColorType
            Case 3 ' paletted
                  If c_TransColor > -1 Then ' use suggest DC backcolor if provided
                     c_Overrides = c_Overrides Or pdNoAlpha
                  End If
            Case 0 ' grayscale; same general principle but a little different

                  If (c_TransColor > -1) Then ' use transparent color if possible
                     c_AlphaColor = GetPaletteValue(-1, c_TransColor + 0)
                  Else
                     If png_WinBKG < 0 Then
                        c_Overrides = c_Overrides Or pdNoAlpha
                     Else
                        c_AlphaColor = png_WinBKG
                     End If
                  End If
            Case 2
                  If c_TransColor > -1 Then
                     ' the transcolor is in BGR, convert to RGB
                     c_AlphaColor = ((c_TransColor And &HFF) * 65536) Or _
                        ((c_TransColor \ 256&) And &HFF) * 256& Or _
                        ((c_TransColor \ 65536) And &HFF)
                  Else
                     If png_WinBKG > -1 Then
                        c_AlphaColor = png_WinBKG
                     Else
                        c_Overrides = c_Overrides Or pdNoAlpha
                     End If
                  End If
            Case Else
                  c_Overrides = c_Overrides Or pdNoAlpha
            End Select
            ' if all else fails, use white vs black. Better IMO
            If c_AlphaColor < 0 And ((c_Overrides And pdNoAlpha) = 0) Then
                  If png_WinBKG < 0 Then
                     c_AlphaColor = vbWhite
                  Else
                     c_AlphaColor = png_WinBKG
                  End If
            End If
         Case Else
            c_AlphaColor = ConvertVBSysColor(c_AlphaBkg)
         End Select
      End If

      ' prevent user from calling any class methods or properties from the
      ' Progress public event....
      c_Overrides = c_Overrides Or pdLocked

End If

End Function

Private Function CalcUncompressedWidth() As Long

Dim uncompressedWidth As Long, iBitPP As Byte
' following for interlaced images
Dim Pass As Long, passWidth As Long, passHeight As Long

On Error GoTo NoLoad

InitializeMatrix

' get the actual bits per pixel the png is using
' (i.e., 16bitdepth png @ ColorType 6 = 64bits per pixel)
GetDepthInfo 0, 0, iBitPP, 0

If png_Interlacing = 0 Then ' no interlacing
      ' uncompressed width will be byte aligned width + 1 for filter byte
      ' multiplied by the height
      passWidth = GetBytesPerPixel(png_Width, iBitPP)
      uncompressedWidth = passWidth * png_Height + png_Height
Else
      ' interlaced will also be byte aligned but per scanline width
      ' Each of the 7 passes can have different widths + 1 filter byte per line
      For Pass = 1 To 7
         ' calculate number of pixels per scan line
         passWidth = png_Width \ MatrixColAdd(Pass) - (png_Width Mod MatrixColAdd(Pass) > MatrixCol(Pass))
         ' determine number of bytes needed for each scanline
         passWidth = GetBytesPerPixel(passWidth, iBitPP)
         ' calculate number of rows for this scan's pass
         passHeight = png_Height \ MatrixRowAdd(Pass) - (png_Height Mod MatrixRowAdd(Pass) > MatrixRow(Pass))
         ' now get the total bytes needed for the entire pass,
         ' adding 1 filter byte for each line in the pass:  i.e., + passHeight
         uncompressedWidth = uncompressedWidth + passWidth * passHeight + passHeight
      Next

End If

CalcUncompressedWidth = uncompressedWidth

NoLoad:
End Function

tmtony · 发表于 2015-6-27 19:39:48

Private Sub InitializeMatrix()

' a quick look up table for bit shifting & palette calculations
ReDim pow2x8(0 To 7)
' using copymemory vs doing the 2^n calculations 8 times
CopyMemory pow2x8(0), 134480385, &H4
CopyMemory pow2x8(4), -2143281136, &H4 ' Array(1,2,4,8,16,32,64,128)

' initialize interlacing matrix, used in the ConvertPNGtoBMP routine and
' also used to calculate the uncompressed size of the compressed PNG data

' Non-interlaced images are considered Pass#8, where interlaced images always
' contain 7 passes (1 thru 7).

' determines what row, in the interlaced image, the current pass begins at
ReDim MatrixRow(1 To 8)
CopyMemory MatrixRow(1), 262144, &H4
CopyMemory MatrixRow(5), 65538, &H4 'Array(0, 0, 4, 0, 2, 0, 1, 0)
' determines what column, in the interlaced image, the current pass begins at
ReDim MatrixCol(1 To 8)
CopyMemory MatrixCol(1), 33555456, &H4
CopyMemory MatrixCol(5), 256&, &H4 'Array(0, 4, 0, 2, 0, 1, 0, 0)
' determines the row interval of the current pass
ReDim MatrixRowAdd(1 To 8)
CopyMemory MatrixRowAdd(1), 67635208, &H4
CopyMemory MatrixRowAdd(5), 16908804, &H4 'Array(8, 8, 8, 4, 4, 2, 2, 1)
' determines the column interval of the current pass
ReDim MatrixColAdd(1 To 8)
CopyMemory MatrixColAdd(1), 67373064, &H4
CopyMemory MatrixColAdd(5), 16843266, &H4 'Array(8, 8, 4, 4, 2, 2, 1, 1)

' 1st 7 elements of next 2 arrays used for pixellated interlaced images

' determines the width of each pixellated pixel for the current pass
ReDim MatrixCX(1 To 8)
CopyMemory MatrixCX(1), 33817608, &H4
CopyMemory MatrixCX(5), 16843010, &H4 'Array(8, 4, 4, 2, 2, 1, 1, 1)
' determines the height of each pixellated pixel for the current pass
MatrixCY() = MatrixColAdd() 'Array(8, 8, 4, 4, 2, 2, 1, 1)

End Sub

Private Sub Class_Terminate()
ClearMemoryVariables ' clean up
Set cPNGimage = Nothing
End Sub

Private Function ClearMemoryVariables()
' // LaVolpe, Dec 15
' Function simply zero's out some key variables for reuse of class & loading other files

If Not cPNGimage Is Nothing Then
      ' no need to exectute lines if no png was previously loaded

      Erase png_Comments()       ' compressed text
      Erase png_Palette()          ' palette data
      Erase png_TransSimple()    ' simple transparency data
      Erase png_LastModified()    ' modified date in byte format
      Erase png_Chromaticity()       ' Chromaticity information
      Erase png_Physical()       ' aspect ratio/physical pixel size information
      Erase png_Offsets()          ' image offset information
      png_sRGB = 0                ' use of standard RGB color space

      Erase pow2x8()             ' bit shifting look up table
      Erase MatrixCol()
      Erase MatrixColAdd()
      Erase MatrixCX()
      Erase MatrixCY()
      Erase MatrixRow()
      Erase MatrixRowAdd()

      cPNGimage.CleanUp_ALL    ' destroy any resources used/created

End If

c_TransColor = -1 ' cached transparent color
png_WinBKG = -1    ' cached pNG suggested window bkg color
c_Overrides = 0    ' class wide options
c_AlphaColor = -1 ' cached alpha color replacement value

End Function

Private Function ConvertVBSysColor(inColor As Long) As Long
On Error GoTo ExitRoutine
If inColor < 0 Then
      ' vb System colors (i.e, vbButton face) are negative & contain the &HFF& value
      ConvertVBSysColor = GetSysColor(inColor And &HFF&)
Else
      ConvertVBSysColor = inColor
End If
Exit Function

ExitRoutine:
ConvertVBSysColor = inColor
End Function

Private Function ConvertPNGtoBMP(rawBytes() As Byte, ByVal scanPass As Byte, _
                  scanCY As Long, rBPRow As Long, startOffset As Long)

' // LaVolpe, Dec 1 thru 10 - Added from Scratch
' 19 Dec -- rewrote to simplify. More & more options made the routine too disorganized
'    added the bNeedAlpha, bNeedBGR, bPackByte flags to categorize needed actions

' This routine (quite big due to various conversion issues) will convert
' PNG bits/bytes to BMP bits/bytes. Common issues to deal with include the
' byte-aligned PNG data may not be the same width as DWord-aligned BMP data. Also,
' BMPs do not support 48bpp nor 2bpp bitmaps. And the biggie: PNGs are RGB
' while DIBs are BGR; otherwise, displaying PNGs would be super quick.

' rawBytes() are the png scanline bytes
' scanPass() is a valid number btwn 1-8 (8 indicates non-interlaced)
' scanCY is number of scanlines (btwn 1 and image height)
' rBPRow is the number of bytes per scanline of the rayBytes array (byte aligned)
' startOffset() is used for scanner-type progression & indicates destination row to begin with

' When no interlacing options are used, this is called once per PNG
' When non-scanner type interlacing is used, called 7 times
' When scanner type interlacing is used, called Height\16+1 times

Dim rRow As Long, rColumn As Long ' current row/column of the png image
Dim dRow As Long, dColumn As Long ' current row/column of destination bitmap
Dim dIndex As Long ' position of dRow in the destBytes() array

Dim dBitPP As Byte, dBytePP As Byte ' nr of bits/bytes per pixel of bitmap
Dim rBytePP As Byte ' nr of bytes per pixel in png image

Dim sub8ptr As Byte ' used to count bits within a byte, for 1,2,4 bpp pngs
Dim tColor As Long  ' color value when copying 3 or 4 bytes to a 3 or 4 byte array
Dim bBlockTransfer As Boolean ' special quick copy flag
Dim blockCX As Long, blockCY As Long, blkIndex As Long
'^^ counter/variables for pixelated interlacing
Dim alphaModifyer As Long, pIndex As Long ' alpha related variables

Dim destBytes() As Byte, workBytes() As Byte ' placeholders for DIB bits (DMA)
Dim TSA As SafeArray1D, TSA_w As SafeArray1D ' array overlays for DIB bits (DMA)
Dim wRowWidth As Long, dRowWidth As Long ' DWord aligned width of bitmap scanline/row

Dim bNeedBGR As Boolean, bPackByte As Boolean, bNeedAlpha As Boolean
'^^ categorized pixel actions

On Error GoTo err_h

' use direct memory access (DMA) to reference the DIB pixel data
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
End With
CopyMemory ByVal VarPtrArray(destBytes), VarPtr(TSA), 4

' determine the bits/bytes of the png and bitmap images
GetDepthInfo dBitPP, dBytePP, 0, rBytePP

' get location of BMP scanline we are processing from PNG scanline
If startOffset Then dRow = startOffset Else dRow = MatrixRow(scanPass)
dRowWidth = (UBound(destBytes) + 1) \ png_Height

If dBitPP < 24 Then
' special case when processing 1, 4 and 8 bpp, non-alpha PNGs
'    doesn't apply when converting RGB to BGR is in effect (bpp>8) and
'    only applies when png & bitmap bits-per-pixel are same
' Can apply to interlaced images too if on the last pass cause every adjacent
' pixel in image's scanline is provided in that pass
bBlockTransfer = (dBitPP = png_BitDepth And scanPass > 6)
' ^^ note: when scanPass=8 then PNG is non-interlaced
End If

tmtony · 发表于 2015-6-27 19:40:13

If Not bBlockTransfer Then

' modified 19 Dec to organize the pixel color transfer process for
' all possible user-selected transformations
      bNeedAlpha = (dBitPP = 32)
      ' ^^ we will need to know the alpha value
      bNeedBGR = (dBitPP > 8 Or ((c_Overrides And pdPixelated) = pdPixelated))
      ' ^^ we will need to know the RGB in BGR format for pixelated progressive or
      ' if the final BMP will be > 8bpp, with the following exception:
      If bNeedAlpha And png_ColorType > 3 And ((c_Overrides And pdNoAlpha) = 0) Then bNeedBGR = False
      ' ^^ Exception: When png has alpha in it, then we don't always need the BGR
      ' value 'cause it will be calculated separately against an alpha multiplyer
      bPackByte = (dBitPP < 8)
      ' ^^ we will need to modify a byte by bit shifting into it
' Note: the only exception not caught here is for non-interlaced, non-alpha 8 bit
' And that is handled just before the pixel is transfered from PNG to BMP

If (c_Overrides And pdPixelated) = pdPixelated Then
      ' interlaced; non-alpha channel png using Pixelated vs FadeIn
      If dBitPP > 8 Then  ' 24bit & 32bit
         ' neat...we can reference the same memory space using different arrays.
         ' 24/32bpp interlaced images are processed with no extra overhead, but our
         ' code below is referencing the workBytes array which is normally another DIB.
         ' Instead of adding double the code for two arrays, we hack it here: Both
         ' the workBytes() and destByes() array will point to the same address space.
         TSA_w = TSA
         CopyMemory ByVal VarPtrArray(workBytes), VarPtr(TSA_w), 4
      Else
         ' non-24bit interlacing are converted to 24bit -- another DIB; so ref it
         With TSA_w
            .cDims = 1                         ' Number of dimensions
            .cbElements = 1                      ' Size of data elements
            .pvData = cPNGimage.PngDataPtr_Working    ' Data address
            .rgSABound.lLbound = 0             ' Low bound of array
            .rgSABound.cElements = cPNGimage.PngDataSize_Working ' Nr of Elements
         End With
         CopyMemory ByVal VarPtrArray(workBytes), VarPtr(TSA_w), 4
      End If
      wRowWidth = (UBound(workBytes) + 1) \ png_Height ' bytes per scanline
End If
End If

For rRow = startOffset To scanCY - 1 ' < in relation to rawBytes() array

dIndex = dRow * dRowWidth ' < destBytes array pointer for 1st pixel in scanline
rColumn = rRow * rBPRow ' < rawBytes array pointer for 1st pixel in scanline

If bBlockTransfer Then
      ' in some cases, we can just copy straight thru but still must do it
      ' row by row cause PNG byte-aligned width may not = BMP DWord aligned width
      CopyMemory destBytes(dIndex), rawBytes(rColumn), rBPRow

Else ' interlaced image

      dColumn = MatrixCol(scanPass) ' column in relation to the destBytes() array
      sub8ptr = 0
      Do While dColumn < png_Width

         If bNeedBGR Then
            ' we need color vs palette index for transfer to 24/32 bit BMP
            Select Case png_ColorType
            Case 2, 6 ' true color without(2)/with(6) alpha
                  If png_BitDepth > 8 Then ' 24,48bpp image
                     tColor = rawBytes(rColumn + 4) Or rawBytes(rColumn + 2) * 256& Or rawBytes(rColumn + 0) * 65536
                  Else
                     tColor = rawBytes(rColumn + 2) Or rawBytes(rColumn + 1) * 256& Or rawBytes(rColumn) * 65536
                  End If
            Case Else ' gray scales(0), gray scale + alpha(4) & paletted(3)
                  tColor = GetPaletteValue(sub8ptr, rawBytes(rColumn), pIndex, True)
            End Select
         End If

         If bNeedAlpha Then
            ' we need the alpha value for transfer to 32 bit BMP
            If (c_Overrides And pdNoAlpha) = pdNoAlpha Then ' no alpha to retrieve
                  alphaModifyer = 255 ' ignore alpha values/user-directed
            Else
                  Select Case png_ColorType
                  Case 2 ' true color + simple transparency
                     If png_BitDepth = 16 Then
                        alphaModifyer = 255
                        If tColor = c_TransColor Then ' c_TransColor is BGR vs RGB
                              ' 16bpp: all 48bits must match to be considered transparent
                              If rawBytes(rColumn + 5) Or rawBytes(rColumn + 3) * 256& Or rawBytes(rColumn + 1) * 65536 = _
                                 (png_TransSimple(4) Or (png_TransSimple(2) * 256&) Or (png_TransSimple(0) * 65536)) Then alphaModifyer = 0
                        End If
                     Else
                        If tColor <> c_TransColor Then alphaModifyer = 255
                     End If
                  Case 3 ' paletted + simple transparency in its own palette-alpha table
                     If png_TransSimple(pIndex) <> 0 Then
                        alphaModifyer = png_TransSimple(pIndex)
                        pIndex = pIndex * 3
                        tColor = ((alphaModifyer * png_Palette(pIndex + 2)) \ 255) Or ((alphaModifyer * png_Palette(pIndex + 1)) \ 255) * 256& Or ((alphaModifyer * png_Palette(pIndex)) \ 255) * 65536
                     End If
                  Case 0 ' grayscale with simple transparency
                     If png_BitDepth = 16 Then
                        alphaModifyer = 255
                        If pIndex = c_TransColor Then
                              ' 16bpp: all 16bits must match to be considered transparent
                              If (rawBytes(rColumn + 1) = png_TransSimple(0)) Then alphaModifyer = 0
                        End If
                     Else
                        If pIndex <> c_TransColor Then alphaModifyer = 255
                     End If
                  Case 4  ' grayscale with alpha
                     If png_BitDepth = 16 Then alphaModifyer = rawBytes(rColumn + 2) Else alphaModifyer = rawBytes(rColumn + 1)
                     If alphaModifyer Then _
                        tColor = ((alphaModifyer * rawBytes(rColumn)) \ 255) Or ((alphaModifyer * rawBytes(rColumn)) \ 255) * 256& Or ((alphaModifyer * rawBytes(rColumn)) \ 255) * 65536
                  Case 6 ' true color with alpha
                     If png_BitDepth = 16 Then
                        alphaModifyer = rawBytes(rColumn + 6)
                        If alphaModifyer Then _
                              tColor = ((alphaModifyer * rawBytes(rColumn + 4)) \ 255) Or ((alphaModifyer * rawBytes(rColumn + 2)) \ 255) * 256& Or ((alphaModifyer * rawBytes(rColumn)) \ 255) * 65536
                     Else
                        alphaModifyer = rawBytes(rColumn + 3)
                        If alphaModifyer Then _
                              tColor = ((alphaModifyer * rawBytes(rColumn + 2)) \ 255) Or ((alphaModifyer * rawBytes(rColumn + 1)) \ 255) * 256& Or ((alphaModifyer * rawBytes(rColumn)) \ 255) * 65536
                     End If
                  End Select
            End If
         End If

         ' write the result to the BMP
         If bPackByte Then
            ' we will be writing to a 1 or 4 bpp BMP
            If png_BitDepth = 1 Then
                  PackByte rawBytes(rColumn), destBytes(dIndex + dColumn \ 8), sub8ptr, dColumn Mod 8
            Else ' 2,4 bpp :: 2bpp pngs converted to 4bpp bitmaps
                  PackByte rawBytes(rColumn), destBytes(dIndex + dColumn \ 2), sub8ptr, dColumn Mod 2
            End If
         ElseIf bNeedAlpha Then
            ' we will be writing to a 32 bpp BMP
            If alphaModifyer Then ' only modify DIB bits if needed
                  destBytes(dIndex + dColumn * 4 + 3) = alphaModifyer
                  CopyMemory destBytes(dIndex + dColumn * 4), tColor, &H3
                  alphaModifyer = 0
            End If
         Else
            ' we will be writing to a 8 or 24 bit BMP
            If bNeedBGR And dBitPP > 8 Then
                  ' 24 bit BMP, dBytePP should always be 3
                  CopyMemory destBytes(dIndex + dColumn * dBytePP), tColor, dBytePP
            Else             ' 8 bit bmp
                  ' note that in this case, the variable tColor is never calculated above
                  destBytes(dIndex + dColumn * dBytePP) = rawBytes(rColumn)
            End If
         End If

         ' ensure our source byte pointer is moved along appropriately
         If png_BitDepth < 8 Then
            sub8ptr = sub8ptr + 1          ' keep track of how many bits processed
            If sub8ptr * png_BitDepth = 8 Then ' when the byte has been processed
                  rColumn = rColumn + 1       ' increment the PNG pointer
                  sub8ptr = 0                ' reset our counter
            End If
         Else
            rColumn = rColumn + rBytePP    ' else increment by source byte pp
         End If

帐号		自动登录	找回密码
密码			注册

群介绍
Access培训群 (792054000)
Access免费培训群2 (792054000)
Access经典源码培训群 (77130759)
Access源码技巧群 (138920637)
access vba (307776555)

主题相关群

地区相关群[您还没设置居住地]

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

相关帖子

群介绍
主题无相 (随机显示版	同地区群块其他地区)