function load transparent PNG picture into userform

KalilMe

Active Member
Joined
Mar 5, 2021
Messages
354
Office Version
  1. 2016
Platform
  1. Windows
hi experts

I hope finding solution for this question. it doesn't seem possible after searching for long time , who knows may be some professionals in this foum have answering
so this function load png pictur but I search for load transparent PNG picture if I have transparent PNG in my PC and load on userform it will change the backcolor to balack color . how can I get rid of the black color and load transparent picture as is existed in my PC?
VBA Code:
Option Explicit
Private Type GUID
    Data1                   As Long
    Data2                   As Integer
    Data3                   As Integer
    Data4(0 To 7)           As Byte
End Type

Private Type PICTDESC
    Size                        As Long
    Type                        As Long
    hPic                        As Long
    hPal                        As Long
End Type

Private Type GdiplusStartupInput
    GdiplusVersion              As Long
    DebugEventCallback          As Long
    SuppressBackgroundThread    As Long
    SuppressExternalCodecs      As Long
End Type

Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, _
    inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, bitmap As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, _
    hbmReturn As Long, ByVal background As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, _
    RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Public Function LoadImage(ByVal strFName As String) As IPicture
    Dim uGdiInput As GdiplusStartupInput
    Dim hGdiPlus As Long
    Dim hGdiImage As Long
    Dim hBitmap As Long

    uGdiInput.GdiplusVersion = 1
    
    If GdiplusStartup(hGdiPlus, uGdiInput) = 0 Then
        If GdipCreateBitmapFromFile(StrPtr(strFName), hGdiImage) = 0 Then
            GdipCreateHBITMAPFromBitmap hGdiImage, hBitmap, 0
            Set LoadImage = ConvertToIPicture(hBitmap)
            GdipDisposeImage hGdiImage
        End If
        GdiplusShutdown hGdiPlus
    End If

End Function

Public Function ConvertToIPicture(ByVal hPic As Long) As IPicture

    Dim uPicInfo As PICTDESC
    Dim IID_IDispatch As GUID
    Dim IPic As IPicture

    Const PICTYPE_BITMAP = 1

    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With

    With uPicInfo
        .Size = Len(uPicInfo)
        .Type = PICTYPE_BITMAP
        .hPic = hPic
        .hPal = 0
    End With

    OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic

    Set ConvertToIPicture = IPic
End Function
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Hi, the good news is that I'm somewhat certain that there is a solution to the problem, but I wont be able to get the answer until early next week when I'm back in the office. That's for what I think is the actual 'proper' solution. But in the interim, below is a hacky little workaround I've come up with which is less-than-ideal, but I think it's interesting...

So the version you've posted looks like code apparently written by Stephen Bullen back in 2006. It uses the GDIPlus APIs. Like you, I was looking for a way to usse transparent PNG files, because the code you're using wasn't working for me either. I stumbled across a "hacky solution" in aa Visual Basic 6 Forum last year, and it actually kinda works, though the quality of the resulting image is questionable. Using a transparent png file of scales, I tried this hacky version - loading it into the picture property of (1) a label control, and (2) and Imagebox. Here are the results.
1638034047836.png
1638034077957.png
So while the one on the left looks good, the white pixels you can make out around the picture on the label control should not be there - this is the loss of quality I was referring to (and the white box in the imagebox ... well that just goes without saying....)

But when I try Stephen Bullen's code next ,loading the image into the picture property of either control, this is the outcome:
1638034288018.png

The imagebox still isn't transparent, but the label control looks much better than earlier. I tried both approaches on the Userform Picture property and neither worked unfortunately.

So my temporary suggestion is to try using your code and load the Png into the picture property of the label control and see if that does what you need. I can try and dig out the revised GDIPlus version when I'm next in the office.

I hope that's ok.
 

Attachments

  • scales.png
    scales.png
    9 KB · Views: 46
Upvote 0
So the version you've posted looks like code apparently written by Stephen Bullen back in 2006
I've found in another forum and solved thread by Andy Pop
I can try and dig out the revised GDIPlus version when I'm next in the office.
I truly appreciate if you can achieve it .:)
 
Upvote 0
I've found in another forum and solved thread by Andy Pop

I truly appreciate if you can achieve it .:)
Can you post a link to the thread in the other forum so others can benefit as well ?

Thanks.
 
Upvote 0
I had to make some slight changes to code, but I've checked it, and it appears to work:

1638349647378.png


The slight change means that you now need to also tell VBA the background colour of the container form/control. So when you want to load a transparent PNG file as a picture for the Userform, you could add the following to the UserForm:

VBA Code:
Me.Picture = LoadImage("D:\FolderName\ImageName.PNG", Me.BackColor)

So, the code for my example above is as follows:

VBA Code:
Private Sub UserForm_Click()
    Me.BackColor = vbWhite
    Me.Picture = LoadImage("D:\ie12.png", Me.BackColor)
    
    Me.Frame1.BackColor = RGB(230, 230, 30)
    Me.Frame1.Picture = LoadImage("D:\ie12.png", Me.Frame1.BackColor)
    
    Me.Label1.BackColor = RGB(0, 120, 120)
    Me.Label1.Picture = LoadImage("D:\ie12.png", Me.Label1.BackColor)
End Sub

I hope that makes sense. Here is the full code, which I have adapted from a version that is compatible with both 32-bit and 64-bit, so that anyone else you needs it can use it too. I would suggest putting the code in its own standard module. Let me know if you have any problems with it.

VBA Code:
'This module provides a LoadPictureGDI function, which can
'be used instead of VBA's LoadPicture, to load a wide variety
'of image types from disk - including png.
'
'The png format is used in Office 2007-2010 to provide images that
'include an alpha channel for each pixel's transparency
'
'Author:    Stephen Bullen
'Date:      31 October, 2006
'Email:     stephen@oaltd.co.uk

'Updated :  30 December, 2010
'By :       Rob Bovey
'Reason :   Also working now in the 64 bit version of Office 2010

'Updated :  01 December, 2021
'Reason :   Adjusted code to allow for optional BackColour parameter
'           to allow for transparent PNG; added BGR function.

Option Explicit

'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type


#If VBA7 Then
    'Declare a UDT to store the bitmap information
    Private Type PICTDESC
        size As Long
        Type As Long
        hPic As LongPtr
        hPal As LongPtr
    End Type
    
    'Declare a UDT to store the GDI+ Startup information
    Private Type GdiplusStartupInput
        GdiplusVersion As Long
        DebugEventCallback As LongPtr
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    End Type
    
    'Windows API calls into the GDI+ library
    Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal FILENAME As LongPtr, BITMAP As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal BITMAP As LongPtr, hbmReturn As LongPtr, ByVal background As LongPtr) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As LongPtr) As Long
    Private Declare PtrSafe Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr)
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
#Else
    'Declare a UDT to store the bitmap information
    Private Type PICTDESC
        size As Long
        Type As Long
        hPic As Long
        hPal As Long
    End Type
    
    'Declare a UDT to store the GDI+ Startup information
    Private Type GdiplusStartupInput
        GdiplusVersion As Long
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    End Type
    
    'Windows API calls into the GDI+ library
    Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, bitmap As Long) As Long
    Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As Long
    Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Long
    Private Declare Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As Long)
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
#End If

' Procedure:    LoadImage
' Purpose:      Loads an image using GDI+
' Returns:      The image as an IPicture Object

Public Function LoadImage(ByVal sFileName As String, Optional PNGBackColor As Long) As IPicture

    Dim uGdiInput As GdiplusStartupInput
    Dim lResult As Long
#If VBA7 Then
    Dim hGdiPlus As LongPtr
    Dim hGdiImage As LongPtr
    Dim hBitmap As LongPtr
#Else
    Dim hGdiPlus As Long
    Dim hGdiImage As Long
    Dim hBitmap As Long
#End If

    'Initialize GDI+
    uGdiInput.GdiplusVersion = 1
    lResult = GdiplusStartup(hGdiPlus, uGdiInput)

    If lResult = 0 Then

        'Load the image
        lResult = GdipCreateBitmapFromFile(StrPtr(sFileName), hGdiImage)

        If lResult = 0 Then

            'Create a bitmap handle from the GDI image
            lResult = GdipCreateHBITMAPFromBitmap(hGdiImage, hBitmap, BGR(PNGBackColor))

            'Create the IPicture object from the bitmap handle
            Set LoadImage = CreateIPicture(hBitmap)

            'Tidy up
            GdipDisposeImage hGdiImage
        End If

        'Shutdown GDI+
        GdiplusShutdown hGdiPlus
    End If

End Function


' Procedure:    CreateIPicture
' Purpose:      Converts a image handle into an IPicture object.
' Returns:      The IPicture object
#If VBA7 Then
Private Function CreateIPicture(ByVal hPic As LongPtr) As IPicture
#Else
Private Function CreateIPicture(ByVal hPic As Long) As IPicture
#End If
    Dim lResult As Long
    Dim uPicinfo As PICTDESC
    Dim IID_IDispatch As GUID
    Dim iPic As IPicture

    'OLE Picture types
    Const PICTYPE_BITMAP = 1

    ' Create the Interface GUID (for the IPicture interface)
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With

    ' Fill uPicInfo with necessary parts.
    With uPicinfo
        .size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hPic
        .hPal = 0
    End With

    ' Create the Picture object.
    lResult = OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, iPic)

    ' Return the new Picture object.
    Set CreateIPicture = iPic

End Function

Function BGR(longColor As Long) As Long
    
    BGR = RGB((longColor \ 65536) Mod 256, (longColor \ 256) Mod 256, (longColor Mod 256))

End Function
 
Upvote 0
@Dan_W

I would suggest first converting the background color from OLE_COLOR to true RGB.

VBA Code:
#If VBA7 Then
    Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As LongPtr, Col As Long) As Long
#Else
    Private Declare Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
#End If

Function BGR(longColor As Long) As Long
    Call TranslateColor(longColor, 0, longColor)
    BGR = RGB((longColor \ 65536) Mod 256, (longColor \ 256) Mod 256, (longColor Mod 256))
End Function
 
Upvote 0
@Jaafar Tribak Thank you very much for the feedback (and for providing the code!) - I'm grateful that you took the time.

I have updated the code below:

VBA Code:
'This module provides a LoadPictureGDI function, which can
'be used instead of VBA's LoadPicture, to load a wide variety
'of image types from disk - including png.
'
'The png format is used in Office 2007-2010 to provide images that
'include an alpha channel for each pixel's transparency
'
'Author:    Stephen Bullen
'Date:      31 October, 2006
'Email:     stephen@oaltd.co.uk

'Updated :  30 December, 2010
'By :       Rob Bovey
'Reason :   Also working now in the 64 bit version of Office 2010

'Updated :  01 December, 2021
'Reason :   Adjusted code to allow for optional BackColour parameter
'           to allow for transparent PNG; added BGR function.

Option Explicit

'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type


#If VBA7 Then
    'Declare a UDT to store the bitmap information
    Private Type PICTDESC
        size As Long
        Type As Long
        hPic As LongPtr
        hPal As LongPtr
    End Type
   
    'Declare a UDT to store the GDI+ Startup information
    Private Type GdiplusStartupInput
        GdiplusVersion As Long
        DebugEventCallback As LongPtr
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    End Type
   
    'Windows API calls into the GDI+ library
    Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal FILENAME As LongPtr, BITMAP As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal BITMAP As LongPtr, hbmReturn As LongPtr, ByVal background As LongPtr) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As LongPtr) As Long
    Private Declare PtrSafe Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr)
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
   
    Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As LongPtr, Col As Long) As Long
#Else
    'Declare a UDT to store the bitmap information
    Private Type PICTDESC
        size As Long
        Type As Long
        hPic As Long
        hPal As Long
    End Type
   
    'Declare a UDT to store the GDI+ Startup information
    Private Type GdiplusStartupInput
        GdiplusVersion As Long
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    End Type
   
    'Windows API calls into the GDI+ library
    Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, bitmap As Long) As Long
    Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As Long
    Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Long
    Private Declare Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As Long)
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

    Private Declare Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
#End If

' Procedure:    LoadImage
' Purpose:      Loads an image using GDI+
' Returns:      The image as an IPicture Object

Public Function LoadImage(ByVal sFileName As String, Optional PNGBackColor As Long) As IPicture

    Dim uGdiInput As GdiplusStartupInput
    Dim lResult As Long
#If VBA7 Then
    Dim hGdiPlus As LongPtr
    Dim hGdiImage As LongPtr
    Dim hBitmap As LongPtr
#Else
    Dim hGdiPlus As Long
    Dim hGdiImage As Long
    Dim hBitmap As Long
#End If

    'Initialize GDI+
    uGdiInput.GdiplusVersion = 1
    lResult = GdiplusStartup(hGdiPlus, uGdiInput)

    If lResult = 0 Then

        'Load the image
        lResult = GdipCreateBitmapFromFile(StrPtr(sFileName), hGdiImage)

        If lResult = 0 Then

            'Create a bitmap handle from the GDI image
            lResult = GdipCreateHBITMAPFromBitmap(hGdiImage, hBitmap, BGR(PNGBackColor))

            'Create the IPicture object from the bitmap handle
            Set LoadImage = CreateIPicture(hBitmap)

            'Tidy up
            GdipDisposeImage hGdiImage
        End If

        'Shutdown GDI+
        GdiplusShutdown hGdiPlus
    End If

End Function


' Procedure:    CreateIPicture
' Purpose:      Converts a image handle into an IPicture object.
' Returns:      The IPicture object
#If VBA7 Then
Private Function CreateIPicture(ByVal hPic As LongPtr) As IPicture
#Else
Private Function CreateIPicture(ByVal hPic As Long) As IPicture
#End If
    Dim lResult As Long
    Dim uPicinfo As PICTDESC
    Dim IID_IDispatch As GUID
    Dim iPic As IPicture

    'OLE Picture types
    Const PICTYPE_BITMAP = 1

    ' Create the Interface GUID (for the IPicture interface)
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With

    ' Fill uPicInfo with necessary parts.
    With uPicinfo
        .size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hPic
        .hPal = 0
    End With

    ' Create the Picture object.
    lResult = OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, iPic)

    ' Return the new Picture object.
    Set CreateIPicture = iPic

End Function

Function BGR(longColor As Long) As Long
   
    Call TranslateColor(longColor, 0, longColor)
    BGR = RGB((longColor \ 65536) Mod 256, (longColor \ 256) Mod 256, (longColor Mod 256))

End Function
 
Upvote 0
Solution
Just for grins, here is a more compact function with some added error handling.

Some usage examples:
VBA Code:
    Me.Picture = LoadPNGImage("D:\ie12.png")
    Me.Frame1.Picture = LoadPNGImage("D:\ie12.png", Me.Frame1.BackColor)
    Me.Label1.Picture = LoadPNGImage("D:\ie12.png", vbRed)


In a Standard Module:
VBA Code:
Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type PICTDESC
    size As Long
    Type As Long
    #If Win64 Then
        hPic As LongLong
        hPal As LongLong
    #Else
        hPic As Long
        hPal As Long
    #End If
End Type

Private Type GdiplusStartupInput
    GdiplusVersion As Long
    #If Win64 Then
        DebugEventCallback As LongLong
    #Else
        DebugEventCallback As Long
    #End If
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As LongPtr, Col As Long) As Long
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    'Windows API calls into the GDI+ library
    Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal FILENAME As LongPtr, BITMAP As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As LongPtr, hbmReturn As LongPtr, ByVal background As LongPtr) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As Long
    Private Declare PtrSafe Sub GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr)
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
#Else
    Private Declare Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    'Windows API calls into the GDI+ library
    Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, bitmap As Long) As Long
    Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As Long
    Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Long
    Private Declare Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As Long)
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
#End If


Public Function LoadPNGImage(ByVal sFileName As String, Optional ByVal PNGBackColor As Variant) As IPicture

    Const PICTYPE_BITMAP = 1
    Const COLOR_BTNFACE = 15

    #If Win64 Then
        Dim hToken As LongLong, hBMP As LongLong, hGdiBmp As LongLong
    #Else
        Dim hToken As Long, hBMP As Long, hGdiBmp As Long
    #End If

    Dim uGdiInput As GdiplusStartupInput
    Dim uPicinfo As PICTDESC, IID_IDispatch As GUID
    Dim sErrMsg As String, sFuncCall As String
    Dim lRGB As Long, lBGR As Long
    Dim lRet As Long

    uGdiInput.GdiplusVersion = 1
  
    lRet = GdiplusStartup(hToken, uGdiInput)
    If lRet Then
        sFuncCall = "'GdiplusStartup'"
        GoTo Xit
    End If
  
    lRet = GdipCreateBitmapFromFile(StrPtr(sFileName), hBMP)
    If lRet Then
        sFuncCall = "'GdipCreateBitmapFromFile'"
        GoTo Xit
    End If
  
   If IsMissing(PNGBackColor) Then
       PNGBackColor = GetSysColor(COLOR_BTNFACE)
   End If
  
    lRet = TranslateColor(PNGBackColor, 0, lRGB)
    If lRet Then
        sFuncCall = "'TranslateColor'"
        GoTo Xit
    End If
  
    lBGR = RGB((lRGB \ 65536) Mod 256, (lRGB \ 256) Mod 256, (lRGB Mod 256))
  
    lRet = GdipCreateHBITMAPFromBitmap(hBMP, hGdiBmp, lBGR)
    If lRet Then
        sFuncCall = "'GdipCreateHBITMAPFromBitmap'"
        GoTo Xit
    End If
  
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicinfo
        .size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hGdiBmp
    End With
    lRet = OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, LoadPNGImage)
    If lRet Then
        sFuncCall = "'OleCreatePictureIndirect'"
        GoTo Xit
    End If

Xit:

    If hBMP Then
        Call GdipDisposeImage(hBMP)
    End If
    If hToken Then
        Call GdiplusShutdown(hToken)
    End If

    If lRet Then
        sErrMsg = "Error: "
        Select Case lRet
            Case 1
                sErrMsg = sErrMsg & "#GenericError"
            Case 2
                sErrMsg = sErrMsg & "#InvalidParameter"
            Case 3
                sErrMsg = sErrMsg & "#OutOfMemory"
            Case 4
                sErrMsg = sErrMsg & "#objectBusy"
            Case 5
                sErrMsg = sErrMsg & "#InsufficientBuffer"
            Case 6
                sErrMsg = sErrMsg & "#NotImplemented"
            Case 7
                sErrMsg = sErrMsg & "#Win32Error"
            Case 8
                sErrMsg = sErrMsg & "#WrongState"
            Case 9
                sErrMsg = sErrMsg & "#Aborted"
            Case 10
                sErrMsg = sErrMsg & "#FileNotFound"
            Case 11
                sErrMsg = sErrMsg & "#ValueOverflow"
            Case 12
                sErrMsg = sErrMsg & "#AccessDenied"
            Case 13
                sErrMsg = sErrMsg & "#UnknownImageFormat"
            Case 14
                sErrMsg = sErrMsg & "#FontFamilyNotFound"
            Case 15
                sErrMsg = sErrMsg & "#FontStyleNotFound"
            Case 16
                sErrMsg = sErrMsg & "#NotTrueTypeFont"
            Case 17
                sErrMsg = sErrMsg & "#UnsupportedGdiplusVersion"
            Case 18
                sErrMsg = sErrMsg & "#GdiplusNotInitialized"
            Case 19
                sErrMsg = sErrMsg & "#PropertyNotFound"
            Case 20
                sErrMsg = sErrMsg & "#PropertyNotSupported"
            Case 21
                sErrMsg = sErrMsg & "#ProfileNotFound"
        End Select
      
        MsgBox sErrMsg & vbNewLine & vbNewLine & "Call: " & sFuncCall
  
    End If

End Function
 
Upvote 0
I'm especially grateful for the error handling section:- I've found it pretty frustrating recently trying to learn GDI / GDIP / OpenGL and not having any idea as to why it just doesn't work.
I've had a quick look at your code, and I think I understand how you've arranged it (and I suspect you could make it even shorter). I suppose the one thing that jumps out at me (for now) is re: IID_IDispatch - you've opted for a different approach... I think I need to look in to that some more.

Thank you again - your code is very useful to study from!
 
Upvote 0

Forum statistics

Threads
1,223,162
Messages
6,170,432
Members
452,326
Latest member
johnshaji

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top