Working with images in VBA - Displaying PNG files

[Dan_W]

Although Excel supports the importing and exporting of PNG files, the image file format is not easy to work with in native VBA, especially when it comes to display PNG images in Userforms/Userform Controls. One option that you may already be aware of is Steve Bullen's PNG loading function using GDI+ (function load transparent PNG picture into userform) - which I reproduce at the linked thread (compatible here in both 32bit and 64bit Office), with further important corrections/input by Jaafar.

Another, less code-intensive option, however, is the WIA COM Object (Windows Image Acquisition). The WIA COM Object has some useful functionality that is accessible from VBA. For some introductory infromation about WIA, see the MS website: Windows Image Acquisition (WIA) - Win32 apps

One very handy use of WIA is the following - it can be used to load any of the standard VBA-compatible image files, but also PNG files:

Function LoadImage(ByVal Filename As String) As StdPicture
        With CreateObject("WIA.ImageFile")
                .LoadFile Filename
                Set LoadImage = .FileData.Picture
        End With
End Function

You can then load a PNG into, say a Userform, with something like:

Private Sub UserForm_Initialize()
        Me.Picture = LoadImage("D:\SAMPLE.PNG")
End Sub

You could even rename the function as LoadPicture, and force VBA to use this custom function as the go-to routine rather than the inbuilt (limited) routine without breaking existing code. The other benefit is that it retains alpha channel transparency, depending on the control you're loading it into.

Transparency in Microsoft Forms​

It may be that you're'already be aware of this, but certain userform controls support bitmaps transparency. You may have noticed that sometimes, when you load an image in the picture property of a label control, the background colour simply disappears - even if there is no alpha channel. Here's an article setting it out: Transparency in Microsoft Forms | Microsoft Docs

In short, you can display PNG files with transparency with the CheckBox, CommandButton, Label, OptionButton and the ToggleButton.

Here's an example of transparency support for bitmaps. Basically, the two images on the left are the original images. Upon transferring them through a simple assignment between the Image control on the left and the label control on the right, part of each image disappears (or, rather, becomes transparent):

​

 

[Dan_W]

Adding PNG images to Userforms/Userform Controls in design-mode
It is possible to add PNG images to the picture property of a UserForm/UserForm Control at design time by leveraging the Microsoft Visual Basic for Application Extensibility Library - you will need to add a reference to it by adding it through Tools -> References -> select the Microsoft Visual Basic for Application Extensibility Library 5.x library. The subroutine below is an example of code you can execute in design-mode to load PNG images into userforms/userform controls.

Assuming that you want to load a PNG file (located at "D:\sample.png") into a label control (called Label1) on userform (called UserForm1), execute the following command in the Immediate Window:

PNG2Picture "D:\Sample.png", "Label1", "UserForm1"

If you leave the filename argument empty, the routine will display an Open File dialogbox from which the image file can be selected:

PNG2Picture , "Label1", "UserForm1"

If you leave the controlname argument empty, the routine will create a new label control in the relevent userform with the name "NewImageControl":

PNG2Picture "D:\Sample.png", , "UserForm1"

If you leave the UserForm argument empty, the routine will assume that you have selected the preferred UserForm. Accordingly, if you leave all three arguments empty, you will be prompted for an image file, and a new control with the name "NewImageControl" will be created in the selected userform:

PNG2Picture

Put the following subroutine code in a standard module:

    Sub PNG2Picture(Optional ByVal Filename As String, Optional ByVal ControlName As String, Optional ByVal VBCName As Variant)
       
        If Len(Filename) = 0 Then
            Filename = Application.GetOpenFilename(FileFilter:="Image Files (*.PNG; *.BMP; *.DIB; *.GIF; *.JPG; *.JPEG), *.PNG;*.BMP;*.DIB;*.GIF;*.JPG;*.JPEG,PNG Image (*.PNG),*.png,Bitmaps Image (*.BMP; *.DIB), *.bmp;*.dib,JPEG Image (*.JPG; *.JPEG), *.jpg;*.jpeg,GIF Image (*.GIF), *.gif, All files (*.*), *.*")
            If Filename = "False" Then Exit Sub
        End If
       
        Dim TargetObject    As MSForms.control
        Dim VBP             As VBProject
        Dim VBC             As VBComponent
        Dim DesignTool      As Object
        Set VBP = Application.VBE.ActiveVBProject
        If IsMissing(VBCName) Then
            Set VBC = Application.VBE.SelectedVBComponent
        Else
            Set VBC = Application.VBE.ActiveVBProject.VBComponents(VBCName)
        End If
        If VBC.HasOpenDesigner Then
            Set DesignTool = VBC.Designer
            On Error Resume Next
            If Len(ControlName) Then
                Set TargetObject = DesignTool.Controls(ControlName)
            Else
                Set TargetObject = DesignTool.Controls.Add("Forms.Label.1", "NewImageControl")
            End If
            On Error GoTo 0
            If Not TargetObject Is Nothing Then
                With TargetObject
                    .Caption = " "
                    .BackStyle = 0
                    .BorderStyle = 0
                    .AutoSize = True
                End With
                With CreateObject("WIA.ImageFile")
                    .LoadFile Filename
                    TargetObject.Picture = .FileData.Picture
                End With
            End If
        End If
    End Sub

 

[Dan_W]

LOAD AN IMAGE FROM A BYTE ARRAY

The WIA COM Object is a useful way of converting an image in the form of a byte array into the stdPicture object - an object that is understood by VBA. The following function accepts a byte array as an argument, and returns an stdPicture object:

    Function ByteArrayToStdPicture(ByVal ImageData As Variant) As StdPicture
        
        With CreateObject("WIA.Vector")
            .BinaryData = ImageData
            Set ByteArrayToStdPicture = .Picture
        End With
        
    End Function

Load an image from Base64
From this point, there are numerous possibilities. For example, a Base64 string is ordinarily converted into a byte array, and saved as a binary file to the local drive before being loaded as an image file. Using WIA, it is possible to convert a Base64 string into a picture without first having to save it to a file - I have an example of it in the following thread where I use Base64 to create a coloured block image dynamically, and then use WIA to convert it into a stdPicture for displaying in the context menu - Right Mouse Click Menu extra functionality

Here is the basic function to do this:

Function Base64toStdPicture(ByVal Base64Code As String) As StdPicture
        
        Dim Node As Object
        Set Node = CreateObject("Msxml2.DOMDocument.3.0").createElement("base64")
        
        Node.DataType = "bin.base64"
        Node.Text = Base64Code
        
        With CreateObject("WIA.Vector")
            .BinaryData = Node.NodeTypedValue
            Set Base64toStdPicture = .Picture
        End With
        
        Set Node = Nothing
        
    End Function

Load an image from a URL
Downloading/displaying an image from a URL is much the same as the byte array. With the following function, it is possible to download an load a picture from a URL without having to save the image the local drive first:

    Function GetImageFromURL(ByVal TargetURL As String) As StdPicture

        Dim HTTP            As Object
        
        Set HTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
        HTTP.Open "GET", TargetURL, False
        HTTP.send

        If HTTP.Status = 200 Then
            With CreateObject("WIA.Vector")
                .BinaryData = HTTP.responseBody
                Set GetImageFromURL = .Picture
            End If
        End If

        Set HTTP = Nothing
        
    End Function

The following example demonstrates how to load an image direct from a URL. You will need a Userform with a label control (called Label1).

Private Sub UserForm_Click()
    With Me
        .BackColor = RGB(80, 116, 85)
        .Width = 370
        .Height = 120
        .Label1.Left = 10
        .Label1.Top = 10
        .Label1.Caption = " "
        .Label1.BackStyle = fmBackStyleTransparent
        .Label1.Picture = GetImageFromURL("https://www.mrexcel.com/board/styles/mrexcel/mrexcel-logo.png")
        .Label1.AutoSize = True
    End With
End Sub

When you run the code and click the Userform, you should see the following:

I use this image as an example to introduce one of the downsides of using the VBA Userform controls with WIA to display images with an alpha channel - this can be solved by using the WIA Stamp function, which I will discuss separately.

 

[Dan_W]

@Jaafar Tribak + @Micron + @TedX - as promised, (part of) my notes on the WIA COM Object.

 

[Jaafar Tribak]

Thank you Dan for this comprehensive and easy to follow article. I am sure it will be very useful for future reference.

 

[Dan_W]

Thank you Dan for this comprehensive and easy to follow article. I am sure it will be very useful for future reference.

You're welcome. I have a few more in the series to write, but I thought I ought to get something up sooner rather than later. As always, any feedback is always appreciated.

 

[Dan_W]

stdPicture/IPicture to Byte Array

Another extremely useful snippet - the ever elusive stdPicture/IPicture to Byte Array method.

I still don't know my way around COM Interfaces, and although wqweto suggests that DispCallFunc could be used, I don't know the first thing about solving this. It took me a while, but I managed to get it working through the InkEdit Control... counterintuitively...

The original thread is here, and it's worth reading the author's explanation: [VB6] Convert a picture to PNG byte-array in memory-VBForums

I reproduce the code below. I have adjusted it to make it compatible with 64bit Office too:

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
#Else
    Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long
#End If

Public Function SaveAsPng(pPic As stdole.IPicture) As Byte()
    Const adTypeBinary  As Long = 1
    Const wiaFormatPNG  As String = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
    Const CC_STDCALL    As Long = 4
    Dim oStream         As Object ' ADODB.Stream
    Dim oImageFile      As Object ' WIA.ImageFile
    Dim IID_IStream(3)  As Long
    Dim pStream         As IUnknown
    Dim vParams(0 To 1) As Variant
    Dim vType(0 To 1)   As Integer
    Dim vPtr(0 To 1)    As LongPtr
    
    '--- load pPic in WIA.ImageFile
    Do While oImageFile Is Nothing
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Type = adTypeBinary
        oStream.Open
        '--- call IUnknown::QI on oStream for IStream interface and store in pStream
        IID_IStream(0) = &HC
        IID_IStream(2) = &HC0
        IID_IStream(3) = &H46000000
        vParams(0) = VarPtr(IID_IStream(0))
        vParams(1) = VarPtr(pStream)
        vType(0) = VarType(vParams(0))
        vType(1) = VarType(vParams(1))
        vPtr(0) = VarPtr(vParams(0))
        vPtr(1) = VarPtr(vParams(1))
        Call DispCallFunc(ObjPtr(oStream), 0, CC_STDCALL, vbLong, UBound(vParams) + 1, vType(0), vPtr(0), Empty)
        '--- NO magic anymore, only business as usual
        pPic.SaveAsFile ByVal ObjPtr(pStream), True, 0
        If oStream.Size = 0 Then
            GoTo QH
        End If
        oStream.Position = 0
        With CreateObject("WIA.Vector")
            .BinaryData = oStream.Read
            If pPic.Type <> 1 Then
                '--- this converts pPic to vbPicTypeBitmap subtype
                Set pPic = .Picture
            Else
                Set oImageFile = .IMageFile
            End If
        End With
    Loop
    '--- serialize WIA.ImageFile to PNG file format
    With CreateObject("WIA.ImageProcess")
        .Filters.Add .FilterInfos("Convert").FilterID
        .Filters(.Filters.Count).Properties("FormatID").Value = wiaFormatPNG
        SaveAsPng = .Apply(oImageFile).FileData.BinaryData
    End With
QH:
End Function

 

[Jaafar Tribak]

Using WIA, it is possible to convert a Base64 string into a picture without first having to save it to a file

The WIA makes working with images unbelievably easy !! It wraps tons of code in a few lines.

In order to convert the bytes of an image to a StdPicture without first having to save it to file, I have used the api approach (GetDIBits, OleLoadPicture etc) . The api approach works but requires tons of code compared to using WIA

Thanks.

 

[Jaafar Tribak]

Hi Dan,

Just for future reference, here is an api method for converting the bytes of an image DIB into a StdPicture w/o needing to save the bitmap to disk.


DiBits_To_StdPicture.xlsm


In a Standard Module

Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

#If VBA7 Then
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hDC As LongPtr, pbmi As BITMAPINFO, ByVal iUsage As Long, ByVal ppvBits As LongPtr, ByVal hSection As LongPtr, ByVal dwOffset As Long) As LongPtr
    Private Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As Any) As Long
    Private Declare PtrSafe Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As LongPtr, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
    Private Declare PtrSafe Function OleLoadPicture Lib "OleAut32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As Long
    Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As LongPtr
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As LongPtr, pbmi As BITMAPINFO, ByVal iUsage As Long, ByVal ppvBits As LongPtr, ByVal hSection As LongPtr, ByVal dwOffset As Long) As LongPtr
    Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As Any) As Long
    Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As LongPtr, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
    Private Declare Function OleLoadPicture Lib "OleAut32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As Long
    Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
    Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
#End If

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As LongPtr
End Type

Private Type BITMAPFILEHEADER
    bfType As String * 2&
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits 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 BITMAPINFO
    bmiheader As BITMAPINFOHEADER
End Type


Function PictureFromByteStream(BitmapBytes() As Byte) As StdPicture

    Const S_OK = 0&, GMEM_MOVEABLE = &H2

    Dim lLowerBound As Long
    Dim lByteCount  As Long
    Dim hMem  As LongPtr
    Dim lpMem  As LongPtr
    Dim IID_IPICTURE(15&)
    Dim ppstm As stdole.IUnknown
 
    On Error GoTo ErrHandler
    If UBound(BitmapBytes, 1&) < 0& Then
        Exit Function
    End If
    lLowerBound = LBound(BitmapBytes)
    lByteCount = (UBound(BitmapBytes) - lLowerBound) + 1&
    hMem = GlobalAlloc(GMEM_MOVEABLE, lByteCount)
    If hMem <> NULL_PTR Then
        lpMem = GlobalLock(hMem)
        If lpMem <> NULL_PTR Then
            Call CopyMemory(ByVal lpMem, BitmapBytes(lLowerBound), lByteCount)
            Call GlobalUnlock(hMem)
            If CreateStreamOnHGlobal(hMem, 1&, ppstm) = S_OK Then
                If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPICTURE(0&)) = S_OK Then
                  If OleLoadPicture(ByVal ObjPtr(ppstm), lByteCount, 0&, IID_IPICTURE(0), PictureFromByteStream) <> S_OK Then
                    MsgBox "Failed to create StdPicture from the bytes."
                  End If
                End If
            End If
        End If
    End If
ErrHandler:
    Call GlobalFree(hMem)
    If Err.Number Then
        MsgBox Err.Description
    End If
End Function

Function GetDIBBits(ByVal BMP As LongPtr) As Byte()

    Const DIB_RGB_COLORS = 0&
    
    Dim tBmpInf As BITMAPINFO, tBmpFileHearder As BITMAPFILEHEADER, tBitmap As BITMAP
    Dim bDIBBits() As Byte
    Dim hDC As LongPtr, hDib As LongPtr
    
    If GetObjectAPI(BMP, LenB(tBitmap), tBitmap) = NULL_PTR Then
        MsgBox "Failed to retrieve info for the bitmap.": GoTo ReleaseHandles
    End If
    With tBmpInf.bmiheader
        .biSize = LenB(tBmpInf.bmiheader)
        .biWidth = tBitmap.bmWidth
        .biHeight = tBitmap.bmHeight
        .biPlanes = 1&
        .biBitCount = 32&
        .biSizeImage = .biWidth * 4& * .biHeight
        hDib = CreateDIBSection(NULL_PTR, tBmpInf, 0&, NULL_PTR, NULL_PTR, 0&)
        If hDib = NULL_PTR Then
            MsgBox "Failed to create a DIB.": GoTo ReleaseHandles
        End If
        'OleLoadPicture expects the graphic byte array to include 54 bytes [file header + Inf header].
        ReDim bDIBBits(0& To .biSizeImage + 53&)
        'Fill bmp file header
        Call CopyMemory(bDIBBits(0&), &H4D42&, 2&)
        Call CopyMemory(bDIBBits(2&), (54& + .biSizeImage), 4&)
        Call CopyMemory(bDIBBits(10&), 54&, 4&)
        'Fill bmp info header
        Call CopyMemory(bDIBBits(14&), tBmpInf, 40&)
        hDC = GetDC(NULL_PTR)
        If GetDIBits(hDC, BMP, 0&, .biHeight, bDIBBits(54&), tBmpInf, DIB_RGB_COLORS) = NULL_PTR Then
            MsgBox "Failed to retrieve the bits of the bitmap.": GoTo ReleaseHandles
        End If
    End With
    GetDIBBits = bDIBBits
ReleaseHandles:
    Call ReleaseDC(NULL_PTR, hDC)
    Call DeleteObject(hDib)

End Function

Example:
This copies image1 to image2 from the DIB data of Image1.

 Set Sheet1.Image2.Picture = PictureFromByteStream(GetDIBBits(Sheet1.Image1.Picture.Handle))

 

[Dan_W]

That's amazing, thank you very much. I've been wanting to look into DIBits more, because they seem like singularly the best of creating/manipulating images, but I figured the moment I start looking into them, I'm going to want to start my 'picturebox class' project from scratch, and I'm so close to getting it done!

BTW, I have the actual list of links (reading list) that you asked for, and importantly, I've found where I got the WIA Help file from, so will post that now. Also going through the process of typing up these notes had made me look into how I've been using WIA, and where it's the best way etc. I have come across a better/quicker way of generating colour bitmaps than the somwhat hacky Base64 process I proposed for the FaceIDs, so will post that too.