Option Explicit

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 PicBmp
   Size As Long
   Type As PICTYPE
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type

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

Public Function CreateIPictureDispFromHBITMAP( _
   ByVal hBitmap As Long, _
   Optional ByVal hPal As Long =  0 , _
   Optional ByVal fPictureOwnsHandle As Boolean = True) As IPictureDisp
 Dim IID_IDispatch As GUID
 Dim Pic As PicBmp

 With Pic
    .Size = Len(Pic)
    .Type = PICTYPE_BITMAP
    .hBmp = hBitmap
    .hPal = hPal
 End With
 With IID_IDispatch
    .Data1 = &H20400
    .Data4( 0 ) = &HC0
    .Data4( 7 ) = &H46
 End With
 OleCreatePictureIndirect Pic, IID_IDispatch, -fPictureOwnsHandle, _
                          CreateIPictureDispFromHBITMAP
End Function

Option Explicit

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

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 SelectObject Lib "gdi32" ( _
   ByVal hDC As Long, ByVal hObject As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function SetBkColor Lib "gdi32" ( _
   ByVal hDC As Long, ByVal crColor As Long) As Long

Private Const SRCCOPY = &HCC0020
Private Declare Function BitBlt Lib "gdi32" ( _
   ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _
   ByVal nWidth As Long, ByVal nHeight As Long, _
   ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
   ByVal dwRop As Long) As Long

Private Declare Function OleTranslateColor Lib "olepro32" ( _
   ByVal OleColor As Long, ByVal hPal As Long, pColorRef As Long) As Long


Public Function CreateMaskPicture(ByVal hbmpSrc As Long, _
                                  ByVal crSrcMaskColor As Long) As IPictureDisp
 'Формирование монохромной маски. Цвет фона (маски) - белый.
 'hbmpSrc не должен быть выбран в каком-либо DC
 Dim hdcSrc As Long
 Dim hdcDst As Long
 Dim bmSrc As BITMAP
 Dim hbmOldSrc As Long
 Dim hbmDst As Long
 Dim hbmOldDst As Long
 Dim crSrcBkG As Long
 
 OleTranslateColor crSrcMaskColor,  0 , crSrcBkG
 
 hdcSrc = CreateCompatibleDC( 0 )
 GetObjectA hbmpSrc, Len(bmSrc), bmSrc
 hbmOldSrc = SelectObject(hdcSrc, hbmpSrc)
 SetBkColor hdcSrc, crSrcBkG
 
 hdcDst = CreateCompatibleDC( 0 )
 hbmDst = CreateCompatibleBitmap(hdcDst, bmSrc.bmWidth, bmSrc.bmHeight)
 hbmOldDst = SelectObject(hdcDst, hbmDst)
 
 BitBlt hdcDst,  0 ,  0 , bmSrc.bmWidth, bmSrc.bmHeight, hdcSrc,  0 ,  0 , SRCCOPY
 
 SelectObject hdcDst, hbmOldDst
 DeleteDC hdcDst
 
 SelectObject hdcSrc, hbmOldSrc
 DeleteDC hdcSrc
 
 Set CreateMaskPicture = CreateIPictureDispFromHBITMAP(hbmDst)
End Function

 Dim hBitmap As Long 'HBITMAP, формируемый средствами GDI
 Dim crBmpMaskColor As Long 'Цвет, играющий роль прозрачного на этом битмапе
 
'...
 
 UserControl.MaskColor = vbWhite
 Set UserControl.MaskPicture = CreateMaskPicture(hBitmap, crBmpMaskColor)
 Set UserControl.Picture = CreateIPictureDispFromHBITMAP(hBitmap,  0 , False)
'hBitmap должен существовать всё время, пока картинка показывается