[VB] The PNG (Portable Network Graphics) Class

[DerVVulfman]

The PNG (Portable Network Graphics) Class
Version: 1.0˃
Based upon work by Elroy of VBForums (June 22, 2022)

Introduction

Permits the loading of standard RGBA type (32bpp).PNG graphics  into a  Visual Basic 6 environment.  Due to their similarities with the format, both .TIF and TIFF graphics files are also usable.

The code has been cleaned up since its original iteration, and provides a more detailed error message system if issues arise.  It also bypasses a false positive error  with certain png files  based on their color indexing.  This false error had halt class processing, now resolved.


Features

• Supports loading of .png files within the Visual Basic 6 environment.
  
• Supports .tif / .tiff images due to format similarities.
  
• Able to define image opacity and scaling on .png file load.
  
• Transparent background support
  
• An updated error message system in the event issues arise.
  
• Easy to use method/command.
  

Limitations

• Does not adapt/update the default LoadPicture command, but uses its own.
  
• LoadPNG (the command/method) does not have palette nor custom size definition properties.
  

Code

Code

Code:

' ==============================================================================
' ** The PNG (Portable Network Graphics) Class
' ------------------------------------------------------------------------------
'    by DerVVulfman
'    version 1.0
'    01-17-2026 (mm/dd/yyyy)
'    Based upon work by Elroy of VBForums (June 22, 2022)
' ==============================================================================
'
' INTRODUCTION:
' -------------
'
' Permits the loading of standard RGBA type (32bpp).PNG graphics  into a  Visual
' Basic 6 environment.  Due to their similarities with the format, both .TIF and
' TIFF graphics files are also usable.
'
' The code has been cleaned up since its original iteration, and provides a more
' detailed error message system if issues arise.  It also bypasses a false posi-
' tive error  with certain png files  based on their color indexing.  This false
' error had halt class processing, now resolved.
'
'
' ==============================================================================
'
' CLASS INSTALLATION:
' -------------------
'
' * In the form where used, define this class before any other action.
'    -- Example:  Private clsPNG As New Class_PNG
'
'   The 'clsPNG' (or like) will direct you to commands within this class.
'    -- Example:  clsPNG.LoadPNG
'
' * Ensure the class instance (or instances) removed from memory upon exit.
'   This is done within the form's  "Form_Unload" private subroutine.
'   -- Example:  Set clsPNG = Nothing
'                End
'
'
' ==============================================================================
'
' METHODS:
' --------
'
' There is only one.  This method acts in place of the LoadPicture command,  but
' with different optional parameters:
'
' LOADPNG:  Loads a PNG file into a supported form object (such as  apicture box,
'           image box, etc.).
' * SYNTAX: <target>.picture = LoadPng(Filename [,opacity [,scaling]] )
'
'  * Target   : the image or picturebox that will contain the graphic
'  * Filename : the image file
'  * Opacity  : (Optional) In byte format. IE &HFF is 255 solid and &H00 is 0.
'  * scaling  : (Optional) in Single Precision floating (1 is default).
'
'            -------------------------------------------------------------------
'            FOR REFERENCE:
'            --------------
'            The default LoadPicture used by VBasic 6 has the following syntax:
'              LoadPicture(Filename [,Size [,Colordepth [,x [,y]]]])
'              * Filename :    The image file
'              * Size :        (0-4) defines if icon, cursor, etc.
'              * Color Depth : (0-3): default, monochrome, 16 colors, 256 colors
'              * X & Y :       Custom Icon size if above Size setting is 4
'            - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
'              Size: (0) - System Small Icon
'                    (1) - System Large-size Icon
'                    (2) - Caption-button size setting
'                    (3) - Icon Size setting on the Appearance Tab
'                    (4) - Custom Size based on further X/Y settings
'            -------------------------------------------------------------------
'
'
' ==============================================================================
'
' ERROR MESSAGES:
' ---------------
'
' Based on the original code by Elroy, the Graphics Error Test Subroutine (GErr)
' is a private subroutine that exists throughout the LoadPng method. If there is
' an issue with the .png file loading, a basic popup window will show the error.
' These error messages may be a simple "Generic Error", "File Not Found", or any
' of the 20+ tracable errors.
'
' There are six different innstances within the LoadPng method  where this error
' message system may be called. Unlike the original code of 2022, the error mes-
' sage will now indicate what stage (loading the GDI system, accessing the file,
' etc) the error occurs.
'
' Being able to track which stage was taking place  when a .png file was loading
' was more of  a development tool, but left within  the error message system for
' possible further debugging if ever needed.
'
'
' ==============================================================================




Option Explicit

' Constant Declarations
' ==============================================================================
    Private Const ImageLockModeRead As Long = &H1&
    Private Const PixelFormat32bppPARGB As Long = &HE200B
    Private Const DIB_RGB_COLORS As Long = 0&
    Private Const AC_SRC_ALPHA As Byte = 1




' Structure Type Declarations
' ==============================================================================
    Private Type GdiplusStartupInput
        GdiplusVersion              As Long
        DebugEventCallback          As Long
        SuppressBackgroundThread    As Long
        SuppressExternalCodecs      As Long
    End Type

    Private Type BitmapData
        Width                       As Long
        Height                      As Long
        Stride                      As Long
        PixelFormat                 As Long
        Scan0                       As Long
        Reserved                    As Long
    End Type

    Private Type BITMAPINFOHEADER
        biSize                      As Long
        biWidth                     As Long
        biHeight                    As Long
        biPlanes                    As Integer
        biBitCount                  As Integer
        biCompression               As Long
        biSizeImage                 As Long
        biXPelsPerMeter             As Long
        biYPelsPerMeter             As Long
        biClrUsed                   As Long
        biClrImportant              As Long
    End Type

    Private Type SIZEL
        cx                          As Long
        cy                          As Long
    End Type

    Private Type RECT
        Left                        As Long
        Top                         As Long
        Right                       As Long
        Bottom                      As Long
    End Type

    Private Type BLENDFUNCTION
        BlendOp                     As Byte
        BlendFlags                  As Byte
        SourceConstantAlpha         As Byte
        AlphaFormat                 As Byte
    End Type

    Private Type PictDesc
        cbSize                      As Long
        picType                     As Long
        hgdiObj                     As Long
        hPalOrXYExt                 As Long
        Reserved                    As Long
    End Type

    Private Type ENHMETAHEADER
        iType                       As Long
        nSize                       As Long
        rclBounds                   As RECT
        rclFrame                    As RECT
        dSignature                  As Long
        nVersion                    As Long
        nBytes                      As Long
        nRecords                    As Long
        nHandles                    As Integer
        sReserved                   As Integer
        nDescription                As Long
        offDescription              As Long
        nPalEntries                 As Long
        szlDevice                   As SIZEL
        szlMillimeters              As SIZEL
        cbPixelFormat               As Long
        offPixelFormat              As Long
        bOpenGL                     As Long
        szlMicrometers              As SIZEL
    End Type

    Private Type IID
        Data1                       As Long
        Data2                       As Integer
        Data3                       As Integer
        Data4(7&)                   As Byte
    End Type




' API Function Declarations
' ==============================================================================

    Private Declare Function GdiplusStartup Lib "gdiplus" _
            (ByRef token As Long, _
            ByRef lpInput As GdiplusStartupInput, _
            Optional ByRef lpOutput As Long) As Long

    Private Declare Function GdipLoadImageFromFile Lib "gdiplus" _
            (ByVal sFilename As Long, hImage As Long) As Long

    Private Declare Function GdipBitmapLockBits Lib "gdiplus" _
            (ByVal hBitmap As Long, lpRect As Any, ByVal lFlags As Long, _
            ByVal lPixelFormat As Long, _
            uLockedBitmapData As BitmapData) As Long

    Private Declare Function CreateCompatibleDC Lib "gdi32" _
            (ByVal hDC As Long) As Long

    Private Declare Function CreateDIBSection Lib "gdi32" _
            (ByVal hDC As Long, lpBitsInfo As BITMAPINFOHEADER, _
            ByVal wUsage As Long, lpBitsOut As Long, _
            ByVal hSection As Long, ByVal offset As Long) As Long

    Private Declare Function GdipBitmapUnlockBits Lib "gdiplus" _
            (ByVal hBitmap As Long, _
            uLockedBitmapData As BitmapData) As Long

    Private Declare Function GdipDisposeImage Lib "gdiplus" _
            (ByVal image As Long) As Long

    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, _
            ByVal hObject As Long) As Long

    Private Declare Function CreateEnhMetaFileW Lib "gdi32" _
            (ByVal hdcRef As Long, _
            ByVal lpFileName As Long, lpRect As Any, _
            ByVal lpDescription As Long) As Long

    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, _
            ByVal nIndex As Long) As Long

    Private Declare Function GetMem4 Lib "msvbvm60" (ByRef Source As Any, _
            ByRef Dest As Any) As Long ' Ignore the returned value. It's useless.

    Private Declare Function GdiAlphaBlend Lib "gdi32" (ByVal hdcDest As Long, _
            ByVal xoriginDest As Long, ByVal yoriginDest As Long, _
            ByVal wDest As Long, ByVal hDest As Long, ByVal hdcSrc As Long, _
            ByVal xoriginSrc As Long, ByVal yoriginSrc As Long, _
            ByVal wSrc As Long, ByVal hSrc As Long, ByVal ftn As Long) As Long

    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

    Private Declare Function DeleteObject Lib "gdi32" _
            (ByVal hObject As Long) As Long

    Private Declare Function CloseEnhMetaFile Lib "gdi32" _
            (ByVal hDC As Long) As Long

    Private Declare Function GetEnhMetaFileHeader Lib "gdi32" _
            (ByVal hEmf As Long, ByVal cbBuffer As Long, _
            ByRef lpemh As ENHMETAHEADER) As Long

    Private Declare Function DeleteEnhMetaFile Lib "gdi32" _
            (ByVal hEmf As Long) As Long

    Private Declare Function OleCreatePictureIndirect Lib "oleaut32" _
            (lpPictDesc As PictDesc, riid As IID, ByVal fOwn As Boolean, _
            lplpvObj As Object) As Long

    Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, _
            ByRef clsid As IID) As Long

    Private Declare Function GdiplusShutdown Lib "gdiplus" _
            (ByVal token As Long) As Long




' API Subroutine Declarations
' ==============================================================================

    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
            (Destination As Any, Source As Any, ByVal Length As Long)

    Private Declare Sub AtlPixelToHiMetric Lib "atl" (lpSizeInPix As SIZEL, _
            lpSizeInHiMetric As SIZEL)




' Variable Declarations
' ==============================================================================
    Private mlGdipToken                 As Long
    Private gdiTestID                   As Integer




' ==============================================================================
' = CLASS FUNCTIONS ============================================================
' ==============================================================================


' The Initialization routine
'===============================================================================
Private Sub Class_Initialize()

End Sub




' ==============================================================================
' = GENERAL FUNCTIONS ==========================================================
' ==============================================================================


' LOADPNG Function
' ==============================================================================
Public Function LoadPng(sFilename As String, _
        Optional ByVal bbOverallOpacity As Byte = &HFF, _
        Optional ByVal dScalingFactor As Single = 1!) As IPicture
    '   ========================================================================
    '
    ' --------------------------------------------------------------------------
    ' The sFilename should be a valid PNG file.
    ' We can put the return of this directly into a PictureBox.Picture or an
    ' Image.Picture, and it will correctly show any alpha channel.
    ' --------------------------------------------------------------------------
    '
    ' Create BLENDFUNCTION structure for an Alpha Blend.
    Const AC_SRC_OVER       As Byte = 0
    Const AC_SRC_ALPHA      As Byte = 1
    '
    ' Initialize function variables
    Dim StartupInput        As GdiplusStartupInput
    Dim hGdipImage          As Long
    Dim uData               As BitmapData
    Dim hMemDC              As Long
    Dim uHdr                As BITMAPINFOHEADER
    Dim hDib                As Long
    Dim lpBits              As Long
    Dim hPrevDib            As Long
    Dim hEmfDC              As Long
    Dim Xscale              As Double
    Dim Yscale              As Double
    Dim bf                  As BLENDFUNCTION
    Dim ftn                 As Long
    Dim hEmf                As Long
    Dim uDesc               As PictDesc
    '
    ' Get the GDI+ going.
    StartupInput.GdiplusVersion = 1&
    gdiTestID = 0
    GErr GdiplusStartup(mlGdipToken, StartupInput, 0&)
    '
    ' Open the file into hGdipImage.
    gdiTestID = 1
    GErr GdipLoadImageFromFile(StrPtr(sFilename), hGdipImage)
    '
    ' Creates a temporary buffer of the hGdipImage's or hGdipBitmap's bits.
    ' The bits in this temp buffer don't have to be the same format as the ori-
    ' ginal bits format. The uData can be both an input and output, but only out-
    ' put here because uData flag is zero. Also PNG files aren't pre-multiplied,
    ' but we let this function do that for us, as that's what we need.
    gdiTestID = 2
    GErr GdipBitmapLockBits(hGdipImage, ByVal 0&, ImageLockModeRead, _
            PixelFormat32bppPARGB, uData)
    '
    ' Get screen compatible DC.
    hMemDC = CreateCompatibleDC(0&)
    '
    ' Fill the BITMAPINFOHEADER header for making DIB.
    uHdr.biSize = Len(uHdr)
    uHdr.biPlanes = 1
    uHdr.biBitCount = 32
    uHdr.biWidth = uData.Width      ' Pixels.
    uHdr.biHeight = -uData.Height   ' Pixels.
    uHdr.biSizeImage = uData.Stride * uData.Height
    '
    ' Create an EMPTY buffer associated with the DC for image (DIB) bits, and
    ' return pointer to the buffer (lpBits). CreateDIBSection does not use the
    ' BITMAPINFOHEADER biXPelsPerMeter or biYPelsPerMeter and will not provide
    ' resolution information in the BITMAPINFO structure.
    hDib = ApiZ(CreateDIBSection(hMemDC, uHdr, DIB_RGB_COLORS, lpBits, 0&, 0&))
    '
    ' Copy the actual image (PARGB bits) from uData (uData.Scan0)
    ' into our DIBs bits (lpBits).
    Call CopyMemory(ByVal lpBits, ByVal uData.Scan0, uData.Stride * uData.Height)
    '
    ' Cleanup - Done with the uData buffer as well as the hGdipImage.
    gdiTestID = 3
    GErr GdipBitmapUnlockBits(hGdipImage, uData)
    gdiTestID = 4
    GErr GdipDisposeImage(hGdipImage)
    '
    ' Put our DIB into our memory DC.
    hPrevDib = ApiZ(SelectObject(hMemDC, hDib))
    '
    ' Create an EMPTY EMF in a primary monitor DC with no initial size.
    ' The DC returned by CreateEnhMetaFile can be passed to any GDI function.
    ' It actually returns an EMF DC.
    hEmfDC = ApiZ(CreateEnhMetaFileW(0&, 0&, ByVal 0&, 0&))
    '
    ' Calculate the EMF scaling factors from its DC, so we can use it in
    ' GdiAlphaBlend, as GdiAlphaBlend scales based on the hEmfDC.
    Const HORZSIZE   As Long = 4&:  Const VERTSIZE   As Long = 6&
    Const HORZRES    As Long = 8&:  Const VERTRES    As Long = 10&
    Const LOGPIXELSX As Long = 88&: Const LOGPIXELSY As Long = 90&
    '
    Xscale = CDbl(GetDeviceCaps(hEmfDC, HORZRES)) / _
        CDbl(GetDeviceCaps(hEmfDC, HORZSIZE)) * 25.4 / _
        CDbl(GetDeviceCaps(hEmfDC, LOGPIXELSX))
        
    Yscale = CDbl(GetDeviceCaps(hEmfDC, VERTRES)) / _
        CDbl(GetDeviceCaps(hEmfDC, VERTSIZE)) * 25.4 / _
        CDbl(GetDeviceCaps(hEmfDC, LOGPIXELSY))
    '
    ' Use BLENDFUNCTION structure for an Alpha Blend.
    bf.BlendOp = AC_SRC_OVER
    bf.AlphaFormat = AC_SRC_ALPHA
    bf.SourceConstantAlpha = bbOverallOpacity
    '
    ' Must put into a Long so we can pass it ByVal.
    GetMem4 bf, ftn
    '
    ' Copy our DIB that's in memory into our EMF+ using its DC, and scale.
    ApiZ GdiAlphaBlend(hEmfDC, 0&, 0&, CLng((CDbl(uData.Width)) * Xscale * _
            dScalingFactor) + 1&, CLng((CDbl(uData.Height)) * Yscale * _
            dScalingFactor) + 1&, hMemDC, 0&, 0&, uData.Width, uData.Height, _
            ftn), "AlphaBlend"
    '
    ' Done with hMemDC and hDib, so clean them up.
    ApiZ SelectObject(hMemDC, hPrevDib)
    ApiZ DeleteDC(hMemDC)
    ApiZ DeleteObject(hDib)
    '
    ' Clean the hEmfDC and save into the hEmf
    hEmf = ApiZ(CloseEnhMetaFile(hEmfDC), "CloseEnhMetaFile")
    '
    ' Setup PictDesc with EMF type.
    uDesc.cbSize = Len(uDesc)
    uDesc.picType = vbPicTypeEMetafile
    uDesc.hgdiObj = hEmf
    '
    ' Return the function by wrapping our EMF (uDesc) into the iPicture object.
    ApiE OleCreatePictureIndirect(uDesc, IPictureIID, 1&, LoadPng)
    '
    ' Shutdown the GDI+.
    gdiTestID = 5
    GErr GdiplusShutdown(mlGdipToken)
    '
End Function




' ==============================================================================
' = PRIVATE FUNCTIONS ==========================================================
' ==============================================================================


' GRAPHICS ERROR TEST SUBROUTINE: Used to check for errors during execution
' ==============================================================================
Private Sub GErr(ByVal GdipReturn As Long)
    '
    ' Initialize subroutine variables
    Dim sErr        As String
    Dim InIDE       As Boolean: Debug.Assert MakeTrue(InIDE)
    '
    If GdipReturn = 0& Then Exit Sub ' All is well.
    '
    ' Exit if the error is after a shutdown of the GDI+
    If GdipReturn = 1& Then
        If gdiTestID = 5 Then
            Exit Sub
        End If
    End If
    '
    ' Branch on returned error to get message
    Select Case GdipReturn
    Case 1&:    sErr = "Generic Error"
    Case 2&:    sErr = "Invalid Parameter/Argument"
    Case 3&:    sErr = "Out Of Memory"
    Case 4&:    sErr = "Object Busy, already in use in another thread"
    Case 5&:    sErr = "Insufficient Buffer, buffer specified as an argument in the API call is not large enough"
    Case 6&:    sErr = "Method Not Implemented"
    Case 7&:    sErr = "Win32 Error"
    Case 8&:    sErr = "Wrong State"
    Case 9&:    sErr = "Method Aborted"
    Case 10&:   sErr = "File Not Found"
    Case 11&:   sErr = "Value Overflow, arithmetic operation that produced a numeric overflow"
    Case 12&:   sErr = "Access Denied"
    Case 13&:   sErr = "Unknown Image Format"
    Case 14&:   sErr = "Font Family Not Found"
    Case 15&:   sErr = "Font Style Not Found"
    Case 16&:   sErr = "Not TrueType Font"
    Case 17&:   sErr = "Unsupported Gdiplus Version"
    Case 18&:   sErr = "Gdiplus Not Initialized"
    Case 19&:   sErr = "Property Not Found, does not exist in the image"
    Case 20&:   sErr = "Property Not Supported, not supported by the format of the image"
    Case 21&:   sErr = "Profile Not Found, color profile required to save an image in CMYK format was not found"
    Case Else:  sErr = "Error Not Specified": GdipReturn = 99&
    End Select
    '
    ' Branch on Test ID to relay which GDI+ command caused the error
    Select Case gdiTestID
    Case 1:    sErr = "1 LoadImage: " & sErr
    Case 2:    sErr = "2 LockBits: " & sErr
    Case 3:    sErr = "3 UnlockBits: " & sErr
    Case 4:    sErr = "4 DisposeImage: " & sErr
    Case 5:    sErr = "5 Shutdown: " & sErr
    Case Else: sErr = "0 Startup: " & sErr
    End Select
    '
    ' Include GDI+ Error notification
    sErr = "GDI+ Error:  " & sErr
    '
    ' Display message in Debug or pass as Raised
    If InIDE Then
        Debug.Print sErr
        Stop
    Else
        Err.Raise vbObjectError + 1147221504 - GdipReturn, , sErr
    End If
    '
End Sub


' Convert a string from the StringFromID back to original IID
' ==============================================================================
Private Function IPictureIID() As IID
    '
    ApiE IIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), _
        IPictureIID)
    '
End Function



' Api Zero:  Processes messages when the error report system returns ZERO
' ==============================================================================
Private Function ApiZ(ApiReturn As Long, Optional sApiCall As String) As Long
    '
    ' Initialize subroutine variables
    Dim sErr        As String
    Dim InIDE       As Boolean: Debug.Assert MakeTrue(InIDE)
    '
    ' Set function to passed value and exit if no Zero return
    If ApiReturn <> 0& Then
        ApiZ = ApiReturn
        Exit Function
    End If
    '
    ' Create error message based on API Call
    If Len(sApiCall) Then
        sErr = sApiCall & " error"
    Else
        sErr = "API Error"
    End If
    '
    ' Display message in Debug or pass as Raised
    If InIDE Then
        Debug.Print sErr
        Stop
    Else
        Err.Raise vbObjectError + 1147221504, , sErr
    End If
End Function


' Api Error:  A General error processing prodcedure for Non-GDI+ errors.
' ==============================================================================
Private Sub ApiE(ApiReturn As Long, Optional sApiCall As String)
    '
    ' Initialize subroutine variables
    Dim sErr        As String
    Dim InIDE       As Boolean: Debug.Assert MakeTrue(InIDE)
    '
    ' Exit if no errors
    If ApiReturn = 0& Then Exit Sub
    '
    ' Create error message based on API Call
    If Len(sApiCall) Then
        sErr = sApiCall & " error " & CStr(ApiReturn)
    Else
        sErr = "API Error " & CStr(ApiReturn)
    End If
    '
    ' Display message in Debug or pass as Raised
    If InIDE Then
        Debug.Print sErr
        Stop
    Else
        Err.Raise vbObjectError + 1147221504 - ApiReturn, , sErr
    End If
    '
End Sub


' Make True - Ensures a passed value is set to boolean/true by ref or otherwise.
' ==============================================================================
Private Function MakeTrue(ByRef b As Boolean) As Boolean
    '
    b = True
    MakeTrue = True
    '
End Function

Or within the actual Class_PNG.cls format:
  Class_Png.zip (Size: 6.35 KB / Downloads: 3)


Instructions
Plenty... in the code itself.


FAQ
The original code was not in the forum of a class, but as a basic module. It has since been streamlined while the error message system upgraded.


Credits and Thanks
Thanks to Elroy of VBForums who wrote the base code in 2022


Terms and Conditions
Use as you see fit. No requirements other than due credit for both Elroy and myself.