Public Function CreateStdPicture(ByVal pixelWidth As Long, ByVal pixelHeight As Long, Optional ByVal ptrToPixels As Long = 0) As StdPicture
  Const planes = 1
  Const bitcount = 32
  
  Dim IID_IDispatch As GUID
  Dim pbmp As PicBmp
  Dim pic As StdPicture
    
  With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0&
    .Data4(7) = &H46&
  End With
    
  With pbmp
    .Size = Len(pbmp)
    .Type = vbPicTypeBitmap
    .hbmp = CreateBitmap(pixelWidth, pixelHeight, planes, bitcount, ByVal ptrToPixels)
    .hPal = &H0&
  End With
    
  OleCreatePictureIndirect pbmp, IID_IDispatch, 1, pic
  Set CreateStdPicture = pic

End Function

'Fixes vertical stripes at some resolutions:
.Bounds(1).cElements = BMP.bmWidth * mvarBytesPerPixel + 3 And &HFFFFFFFC 'ALLAPI BMbits example uses somewhat similar code
'
'Fixes occasional crashes when Clear Method is called:
mvarUBoundX = (UBound(Data, 1) + 1) \ mvarBytesPerPixel - 1 'Fixes Clear Method

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Type PicBmp
    Size As Long
    Type As Long
    hbmp As Long
    hPal As Long
    Reserved As Long
End Type

Public Function CreateDIBPicture(ByVal pixelWidth As Long, ByVal pixelHeight As Long, ByVal BitsPerPixel As Long) As StdPicture
  
  Dim IID_IDispatch As GUID
  Dim pbmp As PicBmp
  Dim pic As StdPicture
    
  With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0&
    .Data4(7) = &H46&
  End With
    
  With pbmp
    .Size = Len(pbmp)
    .Type = vbPicTypeBitmap
    .hbmp = CreateDIB(pixelWidth, pixelHeight, BitsPerPixel)
    .hPal = &H0&
  End With
    
  OleCreatePictureIndirect pbmp, IID_IDispatch, 1, pic
  Set CreateDIBPicture = pic
  
End Function

Private Function CreateDIB(width As Long, height As Long, BitsPerPixel As Long) As Long
  
  Const BI_RGB As Long = 0
  Const DIB_RGB_COLORS As Long = 0

  Dim BMI As BITMAPINFO
  Dim stride As Long, ptrToBits As Long, hdc As Long

  stride = (width * (BitsPerPixel \ 8) + 3) And &HFFFFFFFC
  
  With BMI.bmiHeader
    .biSize = 40
    .biWidth = width
    .biHeight = -height
    .biPlanes = 1
    .biBitCount = BitsPerPixel
    .biCompression = BI_RGB
    .biSizeImage = stride * height
  End With
  
  hdc = CreateCompatibleDC(0)
    CreateDIB = CreateDIBSection(hdc, BMI, DIB_RGB_COLORS, ptrToBits, 0, 0)
  DeleteDC hdc
  
End Function

    .biHeight = -height

Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Type PICTDESC
    Size As Long
    Type As Long
    hbmp As Long
    hPal As Long
    Reserved As Long
End Type

Public Type RGBQUAD
  Blue As Byte
  Green As Byte
  Red As Byte
  Reserved As Byte
End Type

Private Type BITMAPINFOHEADER
    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 BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) 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.dll" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PD As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CreateBitmap Lib "gdi32.dll" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, ByRef lpBits As Any) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal usage As Long, ByRef lpbitmapbits As Long, ByVal hsection As Long, ByVal offset As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal bytes As Long)

Public Function CreateDIB(ByVal width As Long, ByVal height As Long, ByVal bpp As Long, Optional ByVal pointer As Long = 0) As Long
  
  '
  ' create a new Device Independent Bitmap
  '
  ' If pointer is given, the pixel data found at pointer is copied verbatim into the DIB.
  ' (note that the GDI subsystem allocates the memory used to store the pixel data)
  '
  ' * to do: decent error handling
  '
  
  Const BI_RGB As Long = 0
  Const DIB_RGB_COLORS As Long = 0

  Dim BMI As BITMAPINFO, stride As Long, bitmapbits As Long, hdc As Long

  stride = (width * (bpp \ 8) + 3) And &HFFFFFFFC
  
  With BMI.bmiHeader
    .biSize = 40
    .biWidth = width
    .biHeight = -height
    .biPlanes = 1
    .biBitCount = bpp
    .biCompression = BI_RGB
    .biSizeImage = stride * height
  End With
  
  hdc = CreateCompatibleDC(0)
    CreateDIB = CreateDIBSection(hdc, BMI, DIB_RGB_COLORS, bitmapbits, 0, 0)
  DeleteDC hdc
  
  If (pointer <> 0) And (bitmapbits <> 0) Then CopyMemory ByVal bitmapbits, ByVal pointer, BMI.bmiHeader.biSizeImage

End Function

Public Function CreateDDB(ByVal width As Long, ByVal height As Long, Optional ByVal pointer As Long = 0) As Long

  '
  ' Create a new Device Dependent Bitmap (the device being the desktop display)
  ' (uses the desktop's color depth)
  '
  ' If pointer is given, the pixel data found at pointer is copied verbatim into the DDB.
  ' (note that the GDI subsystem allocates the memory used to store the pixel data, often in video memory)
  '
  ' * to do: decent error handling
  '
  
  Const BITSPIXEL As Long = 12
  Const PLANES As Long = 14
  
  Dim hdc As Long, pixelplanes As Long, bpp As Long
  
  hdc = GetDC(0)
    pixelplanes = GetDeviceCaps(hdc, PLANES)
    bpp = GetDeviceCaps(hdc, BITSPIXEL)
  ReleaseDC 0, hdc
  
  CreateDDB = CreateBitmap(width, height, pixelplanes, bpp, ByVal pointer)
  
End Function

Public Function CreateStdPicture(ByVal hbitmap As Long) As StdPicture
  '
  ' given a handle to a bitmap object, wrap a new StdPicture around it.
  '
  ' to do: handle errors better
  '
  Dim IID_IDispatch As GUID, PD As PICTDESC, pic As StdPicture
  
  With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0&
    .Data4(7) = &H46&
  End With
    
  With PD
    .Size = Len(PD)
    .Type = vbPicTypeBitmap
    .hbmp = hbitmap
    .hPal = &H0&
  End With
    
  If OleCreatePictureIndirect(PD, IID_IDispatch, 1, pic) Then Stop
  Set CreateStdPicture = pic
  
End Function

Public Function CreateDDBPicture(ByVal width As Long, ByVal height As Long, Optional ByVal pointer As Long = 0) As StdPicture
  Set CreateDDBPicture = CreateStdPicture(CreateDDB(width, height, pointer))
End Function

Public Function CreateDIBPicture(ByVal width As Long, ByVal height As Long, ByVal bpp As Long, Optional ByVal pointer As Long = 0) As StdPicture
  Set CreateDIBPicture = CreateStdPicture(CreateDIB(width, height, bpp, pointer))
End Function