LoadPictureDataFromIPictureDIB cbrRecordDelete.Picture, Вкладка2

SavePicture cbrRecordDelete.Picture, "Bill.bmp"
Вкладка2.Picture = "Bill.bmp"
Kill "Bill.bmp"

Private Sub Кнопка0_Click()
 Dim cbr As Office.CommandBar
 Dim cbn As Office.CommandBarButton
 
 Set cbr = CommandBars.Add("Custom2", msoBarTop, , True)
 Set cbn = cbr.Controls.Add(msoControlButton, , , , True)
 cbn.FaceId =  358 
 
 LoadPictureDataFromIPictureDIB cbn.Picture, НаборВкладок1.Pages("Вкладка2")
 
 cbn.Delete
 Set cbn = Nothing
 cbr.Delete
 Set cbr = Nothing
End Sub

Option Compare Database
Option Explicit

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 Type BITMAPINFOHEADER '40 bytes
   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 RGBQUAD
   rgbBlue As Byte
   rgbGreen As Byte
   rgbRed As Byte
   rgbReserved As Byte
End Type
Private Const SIZEOF_RGBQUAD =  4 

Private Type BITMAPINFO
   bmiHeader As BITMAPINFOHEADER
   bmiColors As RGBQUAD
End Type

Private Type DIBSECTION
   dsBm As BITMAP
   dsBmih As BITMAPINFOHEADER
   dsBitfields( 0  To  2 ) As Long
   dshSection As Long
   dsOffset 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 DeleteObject Lib "gdi32" ( _
   ByVal hObject As Long) As Long
Private Declare Function GetObjectType Lib "gdi32" ( _
   ByVal hgdiobj As Long) As Long
Private Const OBJ_BITMAP =  7 

Private Declare Function GetActiveWindow Lib "user32" () As Long

Private Declare Function GetDC Lib "user32" ( _
   ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
   ByVal hWnd As Long, ByVal hDC As Long) As Long
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 Declare Function CreateDIBSection Lib "gdi32" ( _
   ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, _
   lpVoid As Any, ByVal Handle As Long, ByVal dw As Long) As Long
Private Const DIB_RGB_COLORS =  0  '  color table in RGBs
Private Declare Function GetDIBColorTableAny Lib "gdi32" _
   Alias "GetDIBColorTable" ( _
   ByVal hDC As Long, ByVal un1 As Long, _
   ByVal un2 As Long, pRGBQuad As Any) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   Destination As Any, Source As Any, ByVal Length As Long)


Public Function LoadPictureDataFromIPictureDIB( _
   SrcPic As stdole.IPicture, ByVal DstObj As Object, _
   Optional ByVal hwndRef As Long =  0 , _
   Optional ByVal ReleasePicRef As Boolean = False) As Boolean
 Dim ds As DIBSECTION
 Dim cbSize As Long
 Dim cbCopied As Long
 Dim hdcRef As Long
 Dim bmi As BITMAPINFO
 Dim hdcMem As Long
 Dim hbmMem As Long
 Dim hbmOld As Long
 Dim bPicData() As Byte
 
 'Ожидается pic.Type=vbPicTypeBitmap=1,GetObjectType(pic.Handle)=OBJ_BITMAP=7
 If GetObjectType(SrcPic.Handle) <> OBJ_BITMAP Then Exit Function

 'Получаем заголовок DIB-секции. Однако, в нём может быть заполнена только
 'структура BITMAP.
 cbSize = LenB(ds)
 ds.dsBmih.biSize = LenB(ds.dsBmih)
 cbCopied = GetObjectA(SrcPic.Handle, cbSize, ds)
 
 If cbCopied = cbSize Then 'DIB-секция полностью заполнена
    If (ds.dsBmih.biClrUsed =  0 ) And (ds.dsBmih.biBitCount <  16 ) Then _
       ds.dsBmih.biClrUsed =  2 & ^ ds.dsBmih.biBitCount
    
    ReDim bPicData( 0  To _
                   ds.dsBmih.biSize + ds.dsBmih.biSizeImage + _
                   ds.dsBmih.biClrUsed * SIZEOF_RGBQUAD -  1 ) As Byte
    
    'Таблица цветов (если есть)
    If ds.dsBmih.biClrUsed And (ds.dsBmih.biBitCount <  16 ) Then
       If hwndRef =  0  Then hwndRef = GetActiveWindow()
       hdcRef = GetDC(hwndRef)
       If hdcRef =  0  Then Exit Function
    
       hdcMem = CreateCompatibleDC(hdcRef)
       hdcRef = ReleaseDC(hwndRef, hdcRef): hdcRef =  0 
       If hdcMem =  0  Then Exit Function
       
       hbmOld = SelectObject(hdcMem, SrcPic.Handle)
       If hbmOld =  0  Then hdcMem = DeleteDC(hdcMem): hdcMem =  0 : Exit Function
       
       cbCopied = GetDIBColorTableAny(hdcMem,  0 , ds.dsBmih.biClrUsed, _
                                      bPicData(ds.dsBmih.biSize))
       If cbCopied <> ds.dsBmih.biClrUsed Then
          Debug.Print "Wrong number of color table entries copied!"
          ReDim Preserve bPicData( 0  To _
                         ds.dsBmih.biSize + ds.dsBmih.biSizeImage + _
                         cbCopied * SIZEOF_RGBQUAD -  1 ) As Byte
       End If
       
       hbmOld = SelectObject(hdcMem, hbmOld): hbmOld =  0 
       hdcMem = DeleteDC(hdcMem): hdcMem =  0 
    End If
 
 ElseIf cbCopied = LenB(ds.dsBm) Then
    'Может оказаться, что картника в терминах GDI является BITMAP-ом,
    'а не DIBSECTION. Приводим её к DIBSECTION.
    If hwndRef =  0  Then hwndRef = GetActiveWindow()
    hdcRef = GetDC(hwndRef)
    If hdcRef =  0  Then Exit Function
 
    hdcMem = CreateCompatibleDC(hdcRef)
    hdcRef = ReleaseDC(hwndRef, hdcRef): hdcRef =  0 
    If hdcMem =  0  Then Exit Function
    
    With bmi.bmiHeader
       .biSize = LenB(bmi.bmiHeader)
       .biPlanes =  1 
       .biBitCount =  32 
       .biWidth = ds.dsBm.bmWidth
       .biHeight = ds.dsBm.bmHeight
    End With
    hbmMem = CreateDIBSection( 0 , bmi, DIB_RGB_COLORS, ByVal  0 &,  0 ,  0 )
    hbmOld = SelectObject(hdcMem, hbmMem)
    If hbmOld =  0  Then
       If hbmMem Then hbmMem = DeleteObject(hbmMem): hbmMem =  0 
       hdcMem = DeleteDC(hdcMem): hdcMem =  0 
       Exit Function
    End If
    
    'Поленился делать отрисовку средствами GDI, но сократил код
    SrcPic.Render hdcMem,  0 , ds.dsBm.bmHeight, ds.dsBm.bmWidth, _
                  -ds.dsBm.bmHeight,  0 ,  0 , SrcPic.Width, SrcPic.Height, ByVal  0 &
    
    hbmOld = SelectObject(hdcMem, hbmOld): hbmOld =  0 
    hdcMem = DeleteDC(hdcMem): hdcMem =  0 
 
    cbSize = LenB(ds)
    cbCopied = GetObjectA(hbmMem, cbSize, ds)
 
    ReDim bPicData( 0  To ds.dsBmih.biSize + ds.dsBmih.biSizeImage -  1 ) As Byte
 Else
    Exit Function
 End If
 
 'Заголовок
 CopyMemory bPicData( 0 ), ds.dsBmih, ds.dsBmih.biSize
 
 'Тело
 CopyMemory bPicData(ds.dsBmih.biSize + _
                     ds.dsBmih.biClrUsed * SIZEOF_RGBQUAD), _
            ByVal ds.dsBm.bmBits, ds.dsBmih.biSizeImage
 If hbmMem Then hbmMem = DeleteObject(hbmMem): hbmMem =  0 
 
 DstObj.PictureData = bPicData
 
 'Освобождаем память
 Erase bPicData
 If ReleasePicRef Then Set SrcPic = Nothing
 
 LoadPictureDataFromIPictureDIB = True
End Function

Option Explicit

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 CreateIC Lib "gdi32" Alias "CreateICA" ( _
   ByVal lpDriverName As String, ByVal lpDeviceName As String, _
   ByVal lpOutput As String, lpInitData As Any) As Long
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 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 DeleteObject Lib "gdi32" ( _
   ByVal hObject As Long) As Long
Private Declare Function GetObjectType Lib "gdi32" ( _
   ByVal hgdiobj As Long) As Long
Private Const OBJ_BITMAP =  7 

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

Private Declare Function GetSysColor Lib "user32" ( _
   ByVal nIndex As Long) As Long
Private Const SYSCOLORMASK As Long = &H80000000

Private Declare Function CreateSolidBrush Lib "gdi32" ( _
   ByVal crColor As Long) As Long

Private Const SRCCOPY = &HCC0020         ' (DWORD) dest = source
Private Const ROP3_DSna = &H220326
Private Const ROP3_DPSao = &HEA02E9

Private Declare Function BitBlt Lib "gdi32" ( _
   ByVal hdcDst As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
   ByVal nHeight As Long, ByVal hdcSrc As Long, _
   ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long


Public Function CombinePicMask( _
   ByVal pdPic As IPictureDisp, ByVal pdMsk As IPictureDisp, _
   Optional ByVal BackColor As Long =  12632256 ) As IPictureDisp
 Dim hicRef As Long
 Dim hdcSrc As Long
 Dim hdcMsk As Long
 Dim hdcDst As Long
 Dim hbmSrc As Long
 Dim hbmMsk As Long
 Dim hbmDst As Long
 Dim hbmSrcOld As Long
 Dim hbmMskOld As Long
 Dim hbmDstOld As Long
 Dim cbSize As Long
 Dim cbCopied As Long
 Dim bmSrc As BITMAP
 Dim bmMsk As BITMAP
 Dim hbrDst As Long
 Dim hbrDstOld As Long
 
 'Проверка входных параметров
 If (pdPic Is Nothing) Or (pdMsk Is Nothing) Then Exit Function
 hbmSrc = pdPic.Handle
 If GetObjectType(hbmSrc) <> OBJ_BITMAP Then Exit Function
 hbmMsk = pdMsk.Handle
 If GetObjectType(hbmMsk) <> OBJ_BITMAP Then Exit Function
 cbSize = LenB(bmSrc)
 cbCopied = GetObjectA(hbmSrc, cbSize, bmSrc)
 If cbSize <> cbCopied Then Exit Function
 cbCopied = GetObjectA(hbmMsk, cbSize, bmMsk)
 If cbSize <> cbCopied Then Exit Function
 If (bmSrc.bmWidth <> bmMsk.bmWidth) Or _
    (bmSrc.bmHeight <> bmMsk.bmHeight) Then Exit Function
 
 'Создание контекстов устройств для манипуляций с растровыми изображениями
 hicRef = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal  0 &)
 hdcSrc = CreateCompatibleDC(hicRef)
 hdcMsk = CreateCompatibleDC(hicRef)
 hdcDst = CreateCompatibleDC(hicRef)
 
 'Выбор и создание растровых изображений
 hbmSrcOld = SelectObject(hdcSrc, hbmSrc)
 hbmMskOld = SelectObject(hdcMsk, hbmMsk)
 hbmDst = CreateCompatibleBitmap(hicRef, bmSrc.bmWidth, bmSrc.bmHeight)
 hbmDstOld = SelectObject(hdcDst, hbmDst)
 
 'Создание и выбор фоновой кисти
 If BackColor And SYSCOLORMASK Then _
    BackColor = GetSysColor(BackColor Xor SYSCOLORMASK)
 hbrDst = CreateSolidBrush(BackColor)
 hbrDstOld = SelectObject(hdcDst, hbrDst)
 
 'Наложение изображений, подмена фона.
 'Незначительно отличается от классического ((D xor S) and M) xor S.
 'Не стал возиться с MaskBlt().
 BitBlt hdcDst,  0 ,  0 , bmSrc.bmWidth, bmSrc.bmHeight, hdcSrc,  0 ,  0 , SRCCOPY
 BitBlt hdcDst,  0 ,  0 , bmSrc.bmWidth, bmSrc.bmHeight, hdcMsk,  0 ,  0 , ROP3_DSna
 BitBlt hdcDst,  0 ,  0 , bmSrc.bmWidth, bmSrc.bmHeight, hdcMsk,  0 ,  0 , ROP3_DPSao
 
 'Выбор старых объектов и уничтожение созданных
 SelectObject hdcDst, hbrDstOld
 DeleteObject hbrDst
 
 SelectObject hdcDst, hbmDstOld
 SelectObject hdcMsk, hbmMskOld
 SelectObject hdcSrc, hbmSrcOld
 
 DeleteDC hdcDst
 DeleteDC hdcMsk
 DeleteDC hdcSrc
 DeleteDC hicRef
 
 'Возврат результата в объектном виде
 Set CombinePicMask = CreateIPictureDispFromHBITMAP(hbmDst)
End Function

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

Private Sub Кнопка0_Click()
 Dim cbr As Office.CommandBar
 Dim cbn As Office.CommandBarButton
 
 Set cbr = CommandBars.Add("Custom2", msoBarTop, , True)
 Set cbn = cbr.Controls.Add(msoControlButton, , , , True)
 cbn.FaceId =  358 
 
 LoadPictureDataFromIPictureDIB CombinePicMask(cbn.Picture, cbn.Mask), _
                                НаборВкладок1.Pages("Вкладка2")
 
 cbn.Delete
 Set cbn = Nothing
 cbr.Delete
 Set cbr = Nothing
End Sub