Option Explicit

Private Enum BOOL
   FALSE_BOOL
   TRUE_BOOL
End Enum

Private Type BITMAP '24 bytes
   bmType As Long
   bmWidth As Long
   bmHeight As Long
   bmWidthBytes As Long
   bmPlanes As Integer
   bmBitsPixel As Integer
   bmBits As Long
End Type

Private Declare Function GetObjectA Lib "gdi32" ( _
   ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
   ByVal hObject As Long) As Long
Private Enum GdiObjectType
   OBJ_BITMAP =  7 
End Enum
Private Declare Function GetObjectType Lib "gdi32" ( _
   ByVal hgdiobj As Long) As GdiObjectType

Private Declare Function CreateBitmap Lib "gdi32" ( _
   ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, _
   ByVal nBitCount As Long, lpBits As Any) As Long

Private Type ICONINFO
   fIcon As BOOL
   xHotspot As Long
   yHotspot As Long
   hbmMask As Long
   hbmColor As Long
End Type
Private Declare Function CreateIconIndirect Lib "user32" ( _
   piconinfo As ICONINFO) As Long

Private Enum PICTYPE
   PICTYPE_UNINITIALIZED = - 1 
   PICTYPE_NONE =  0 
   PICTYPE_BITMAP =  1 
   PICTYPE_METAFILE =  2 
   PICTYPE_ICON =  3 
   PICTYPE_ENHMETAFILE =  4 
End Enum

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

Private Type picIcon
   Size As Long
   Type As PICTYPE
   hIcon As Long
   Reserved1 As Long
   Reserved2 As Long
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32" ( _
   PicDesc As Any, RefIID As GUID, _
   ByVal fPictureOwnsHandle As BOOL, IPic As IPictureDisp) As Long

Public Function CreateIPictureDispFromHICON( _
   ByVal hIcon As Long, _
   Optional ByVal fPictureOwnsHandle As Boolean = True) As IPictureDisp
 Dim IID_IDispatch As GUID
 Dim Pic As picIcon
 With Pic
    .Size = Len(Pic)
    .Type = PICTYPE_ICON
    .hIcon = hIcon
 End With
 With IID_IDispatch
    .Data1 = &H20400
    .Data4( 0 ) = &HC0
    .Data4( 7 ) = &H46
 End With
 OleCreatePictureIndirect Pic, IID_IDispatch, -fPictureOwnsHandle, _
                          CreateIPictureDispFromHICON
End Function

Public Function CreateAlphaIcon(ByVal hbmpARGB As Long) As IPictureDisp
 Dim cbSize As Long
 Dim cbCopied As Long
 Dim bmARGB As BITMAP
 Dim hbmpMono As Long
 Dim ii As ICONINFO
 Dim hiconAlpha As Long
 
 If GetObjectType(hbmpARGB) <> OBJ_BITMAP Then Exit Function
 cbSize = LenB(bmARGB)
 cbCopied = GetObjectA(hbmpARGB, cbSize, bmARGB)
 If cbSize <> cbCopied Then Exit Function
 
 hbmpMono = CreateBitmap(bmARGB.bmWidth, bmARGB.bmHeight,  1 ,  1 , ByVal  0 &)
 ii.fIcon = TRUE_BOOL
 ii.xHotspot =  0 
 ii.yHotspot =  0 
 ii.hbmMask = hbmpMono
 ii.hbmColor = hbmpARGB
 hiconAlpha = CreateIconIndirect(ii)
 DeleteObject hbmpMono
 
 If hiconAlpha =  0  Then Exit Function
 Set CreateAlphaIcon = CreateIPictureDispFromHICON(hiconAlpha)
End Function

Sub Test
 Dim cImg As New cAlphaDibSection
 Dim cMsk As New cAlphaDibSection
 'Берём 24-битный цветной битмап
 cImg.CreateFromPicture LoadPicture(CurrentProject.Path & "\point-blue.bmp")
 'Берём отдельный битмап с альфа-каналом (оттенки серого)
 cMsk.CreateFromPicture LoadPicture(CurrentProject.Path & "\point-blue-alpha.bmp")
 'Складываем
 cImg.ApplyAlphaChannel cMsk 'Получили 32-битный битмап с альфа-каналом
 
 'Сохраняем, если нужно
 'cImg.SavePicture CurrentProject.Path & "\point-blue-argb.bmp"
 'На стандартные LoadPicture, SavePicture не надейтесь

 'Создаём из битмапа иконку, завёрнутую в IPictureDisp
 Dim picIcon As IPictureDisp
 Set picIcon = CreateAlphaIcon(cImg.hDib)

 'Далее пытаемся применить в Ribbon или ещё где
 '...
End Sub

Public Sub GetImage32(Control, ByRef image)
 Dim cImg As New cAlphaDibSection
 Dim cMsk As New cAlphaDibSection
 
 cImg.CreateFromPicture LoadPicture(CurrentProject.Path & "\point-blue.bmp")
 cMsk.CreateFromPicture LoadPicture(CurrentProject.Path & "\point-blue-alpha.bmp")
 
 cImg.ApplyAlphaChannel cMsk

 Set image = CreateIPictureDispFromHBITMAP(cImg.hDib,  0 , False)
End Sub

 'в области описаний
 Public DeleteDibOnTerminate As Boolean

 'новый метод
Private Sub Class_Initialize()
 DeleteDibOnTerminate = True
End Sub

'В методе ClearUp
Public Sub ClearUp()
'...
    'Вместо DeleteObject m_hDIb:
    If DeleteDibOnTerminate Then DeleteObject m_hDIb
'...
End Sub

Public Sub GetImage32(Control, ByRef image)
 Dim cImg As New cAlphaDibSection
 Dim cMsk As New cAlphaDibSection
 
 cImg.CreateFromPicture LoadPicture(CurrentProject.Path & "\point-blue.bmp")
 cMsk.CreateFromPicture LoadPicture(CurrentProject.Path & "\point-blue-alpha.bmp")
 
 cImg.ApplyAlphaChannel cMsk
 cImg.DeleteDibOnTerminate = False

 Set image = CreateIPictureDispFromHBITMAP(cImg.hDib)
End Sub

Option Explicit

Private Enum BOOL
   FALSE_BOOL
   TRUE_BOOL
End Enum

Private Enum GpStatus 'GDI+ Status
   OK =  0 
   GenericError =  1 
   InvalidParameter =  2 
   OutOfMemory =  3 
   ObjectBusy =  4 
   InsufficientBuffer =  5 
   NotImplemented =  6 
   Win32Error =  7 
   WrongState =  8 
   Aborted =  9 
   FileNotFound =  10 
   ValueOverflow =  11 
   AccessDenied =  12 
   UnknownImageFormat =  13 
   FontFamilyNotFound =  14 
   FontStyleNotFound =  15 
   NotTrueTypeFont =  16 
   UnsupportedGdiplusVersion =  17 
   GdiplusNotInitialized =  18 
   PropertyNotFound =  19 
   PropertyNotSupported =  20 
   ProfileNotFound =  21 
End Enum

Private Enum GdiplusVersion
   Ver1 =  1 
End Enum

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

Private Declare Function GdiplusStartup Lib "gdiplus" ( _
   lToken As Long, lpInput As GdiplusStartupInput, _
   Optional ByRef lpOutput As Any) As GpStatus
Private Declare Function GdiplusShutdown Lib "gdiplus" ( _
   ByVal lToken As Long) As GpStatus

Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" ( _
   ByVal wszFileName As Long, nBitmap As Long) As GpStatus
'Private Declare Function GdipCreateBitmapFromStream Lib "gdiplus" ( _
'   ByVal Stream As IUnknown, nBitmap As Long) As GpStatus
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" ( _
   ByVal nBitmap As Long, hbmReturn As Long, _
   ByVal argbBackground As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "gdiplus" ( _
   ByVal nImage As Long) As GpStatus

Public Function LoadBitmapPicture(ByVal sFileName As String) As IPictureDisp
 Dim GdipToken As Long
 Dim si As GdiplusStartupInput
 Dim nBitmap As Long
 Dim hBitmap As Long
 si.GdiplusVersion = Ver1
 GdiplusStartup GdipToken, si, ByVal  0 &
 If GdipToken =  0  Then Exit Function
 GdipCreateBitmapFromFile StrPtr(sFileName), nBitmap
 If nBitmap Then
    GdipCreateHBITMAPFromBitmap nBitmap, hBitmap,  0 
    Set LoadBitmapPicture = CreateIPictureDispFromHBITMAP(hBitmap)
    GdipDisposeImage nBitmap
 End If
 GdiplusShutdown GdipToken
End Function