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 Long =  1 ) 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 CreateCompatibleBitmap Lib "gdi32" ( _
   ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" ( _
   ByVal hDC As Long) As Long

Private Declare Function SelectObject Lib "gdi32" ( _
   ByVal hDC As Long, ByVal hObject As Long) As Long
'Private Declare Function DeleteObject Lib "gdi32" ( _
'   ByVal hObject As Long) As Long

Private Declare Function SetPixel Lib "gdi32" ( _
   ByVal hDC As Long, ByVal x As Long, ByVal y As Long, _
   ByVal crColor As Long) As Long

Private Sub Command1_Click()
 Dim hbmMem As Long
 Dim hdcMem As Long
 Dim hbmOld As Long
 
 hbmMem = CreateCompatibleBitmap(Picture1.hDC,  2000 ,  2000 )
 If hbmMem =  0  Then Exit Sub
 hdcMem = CreateCompatibleDC(Picture1.hDC)
 hbmOld = SelectObject(hdcMem, hbmMem)
 
 'Под Win9x следует почистить битмап, нарисовав чёрный прямоугольник
 SetPixel hdcMem,  10 ,  20 , RGB( 255 ,  0 ,  0 )
 SetPixel hdcMem,  20 ,  40 , RGB( 0 ,  255 ,  0 )
 SetPixel hdcMem,  10 ,  40 , RGB( 0 ,  0 ,  255 )
 
 SelectObject hdcMem, hbmOld
 DeleteDC hdcMem
 
 Set Picture1.Picture = CreateIPictureDispFromHBITMAP(hbmMem)
End Sub