[API]
CreateBitmap
CreateCompatibleDC
SelectObject
BitBlt
DeleteDC

[CODE]
Public Function BitmapToSpecificBitmap(ByVal hBmp As Long, ByVal Width As Long, ByVal Height As Long, ByVal BitsPerPixel As Long)
  Dim hDC1 As Long
  Dim hDC2 As Long
  Dim hBmp1 As Long
  Dim hBmpOld1 As Long
  Dim hBmpOld2 As Long
  
  hBmp1 = CreateBitmap(Width, Height, 1&, BitsPerPixel, ByVal 0&)
  If Not hBmp1 = 0& Then
    hDC1 = CreateCompatibleDC(0&)
    If Not hDC1 = 0& Then
      hBmpOld1 = SelectObject(hDC1, hBmp1)
      If Not hBmpOld1 = 0& Then
        hDC2 = CreateCompatibleDC(0&)
        If Not hDC2 = 0& Then
          hBmpOld2 = SelectObject(hDC2, hBmp)
          If Not hBmpOld2 = 0& Then
            If Not BitBlt(hDC1, 0&, 0&, Width, Height, hDC2, 0&, 0&, vbSrcCopy) = 0& Then
              BitmapToSpecificBitmap = hBmp1
              End If
            Call SelectObject(hDC, hBmpOld2)
            End If
          Call DeleteDC(hDC2)
          End If
        Call SelectObject(hDC, hBmpOld1)
        End If
      Call DeleteDC(hDC1)
      End If
    If BitmapToSpecificBitmap = 0& Then
      Call DeleteObject(hBmp1)
      End If
    End If
  End Function
