+- Save-Point (https://www.save-point.org)
+-- Forum: Material Development (https://www.save-point.org/forum-8.html)
+--- Forum: Direct Compilable Code (https://www.save-point.org/forum-193.html)
+--- Thread: [VB] The PNG (Portable Network Graphics) Class (/thread-13388.html)
The PNG (Portable Network Graphics) Class - DerVVulfman - 01-18-2026
The PNG (Portable Network Graphics) Class
Version: 1.0˃
Based upon work by Elroy of VBForums (June 22, 2022)
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
Class_Png.zip (Size: 6.35 KB / Downloads: 0)
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.