Creating a new GDI Bitmap from a VB Picture or DC

If you're creating some code which works with VB but draws with the more powerful GDI functions, it's often very handy to be able to create a new bitmap handle from a VB StdPicture object or from an area of a DC. This article demonstrates how to do this with a few lines of GDI code.

Start a new project in VB, add a module to it and paste in the following code:

Private Type BITMAP
    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 GetObjectAPI Lib "gdi32" Alias "GetObjectA" ( _
      ByVal hObject As Long, _
      ByVal nCount As Long, _
      lpObject As Any _
   ) As Long
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" ( _
      ByVal lpDriverName As String, _
      lpDeviceName As Any, _
      lpOutput As Any, _
      lpInitData As Any _
    ) 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 hObj As Long _
    ) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
       ByVal hObj 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 CreateCompatibleDC Lib "gdi32" ( _
       ByVal hdc As Long _
    ) As Long
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
Public Declare Function DeleteObject Lib "gdi32" ( _
       ByVal hObject As Long _
    ) As Long

Public Function HBitmapFromPicture(picThis As IPicture) As Long

   ' Create a copy of the bitmap:
   Dim lhDC As Long
   Dim lhDCCopy As Long
   Dim lhBmpCopy As Long
   Dim lhBmpCopyOld As Long
   Dim lhBmpOld As Long
   Dim lhDCC As Long
   Dim tBM As BITMAP

   GetObjectAPI picThis.Handle, Len(tBM), tBM
   lhDCC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
   lhDC = CreateCompatibleDC(lhDCC)
   lhBmpOld = SelectObject(lhDC, picThis.Handle)

   lhDCCopy = CreateCompatibleDC(lhDCC)
   lhBmpCopy = CreateCompatibleBitmap(lhDCC, tBM.bmWidth, tBM.bmHeight)
   lhBmpCopyOld = SelectObject(lhDCCopy, lhBmpCopy)

   BitBlt lhDCCopy, 0, 0, tBM.bmWidth, tBM.bmHeight, lhDC, 0, 0, vbSrcCopy

   If Not (lhDCC = 0) Then
      DeleteDC lhDCC
   End If
   If Not (lhBmpOld = 0) Then
      SelectObject lhDC, lhBmpOld
   End If
   If Not (lhDC = 0) Then
      DeleteDC lhDC
   End If
   If Not (lhBmpCopyOld = 0) Then
      SelectObject lhDCCopy, lhBmpCopyOld
   End If
   If Not (lhDCCopy = 0) Then
      DeleteDC lhDCCopy
   End If

   HBitmapFromPicture = lhBmpCopy

End Sub

Public Function HBitmapFromDC( _
      ByVal lhDC As Long, _
      ByVal lWidth As Long, _
      ByVal lHeight As Long _
   ) As Long

   ' Copy the bitmap in lHDC:
   Dim lhDCCopy As Long
   Dim lhBmpCopy As Long
   Dim lhBmpCopyOld As Long
   Dim lhDCC As Long
   Dim tBM As BITMAP
   
   lhDCC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
   lhDCCopy = CreateCompatibleDC(lhDCC)
   lhBmpCopy = CreateCompatibleBitmap(lhDCC, lWidth, lHeight)
   lhBmpCopyOld = SelectObject(lhDCCopy, lhBmpCopy)

   BitBlt lhDCCopy, 0, 0, lWidth, lHeight, lhDC, 0, 0, vbSrcCopy

   If Not (lhDCC = 0) Then
      DeleteDC lhDCC
   End If
   If Not (lhBmpCopyOld = 0) Then
      SelectObject lhDCCopy, lhBmpCopyOld
   End If
   If Not (lhDCCopy = 0) Then
      DeleteDC lhDCCopy
   End If

   HBitmapFromDC = lhBmpCopy

End Sub
    

To test out the functions, add a PictureBox to the project's form, and load a picture into it. Then add a CommandButton and the following code:

Private Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type

Private Declare Function CreatePatternBrush Lib "gdi32" ( _
       ByVal hBitmap As Long _
    ) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
       ByVal hObj As Long _
    ) As Long
Private Declare Function FillRect Lib "user32" ( _
       ByVal hdc As Long, _
       lpRect As RECT, _
       ByVal hBrush As Long _
    ) As Long

Private Sub Command1_Click()
   Dim hBmp As Long
   hBmp = HBitmapFromPicture(Picture1.Picture)
   Dim bBr As Long
   hBr = CreatePatternBrush(hBmp)
   DeleteObject hBmp

   Dim tR As RECT
   tR.Left = Rnd * Me.ScaleWidth \ Screen.TwipsPerPixelX
   tR.Top = Rnd * Me.ScaleHeight \ Screen.TwipsPerPixelY
   tR.Right = tR.Left + Rnd * Me.ScaleWidth \ (Screen.TwipsPerPixelX * 2)
   tR.Bottom = tR.Top + Rnd * Me.ScaleHeight \ (Screen.TwipsPerPixelY * 2)
   FillRect Me.hDC, tR, hBr
   DeleteObject hBr

End Sub
    

Whenever you click the button, the picture's image will be copied and a new bitmap brush created and a random rectangle filled on the window with the image.