createMemoryBitMapAndSave.vb

' so in summary, there are three ways to create memory bitmap and use it.
' createbitmap header, info structure --> put to disk file --> load to userform
' createbitmap header, info struction --> use copy memory to construct a IPicture --> load to userform
' use OleCreatePictureIndirect API call to save from bitmap handle directly.
' no need to mess with bitmap header or other low level detail.

' i like method 2, it is the most difficutl one, but i learned a lot about Win32 API and VB.
' Especially User Defined Type. and CopyMemory function.

' this example uses PUT method to save BitMapHeader and BitMapInfo struct to disk.
' followed by pixel color array. 

Private Declare PtrSafe Function CreateCompatibleDC Lib "Gdi32" (ByVal hDc As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "Gdi32" (ByVal hDc As LongPtr, _
        ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "Gdi32" (ByVal hDc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function GetStockObject Lib "Gdi32" (ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function Rectangle Lib "Gdi32" (ByVal hDc As LongPtr, _
        ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare PtrSafe Function MoveToEx Lib "Gdi32" (ByVal hDc As LongPtr, _
        ByVal x As Long, ByVal y As Long, lpPoint As Any) As Long
Private Declare PtrSafe Function LineTo Lib "Gdi32" (ByVal hDc As LongPtr, ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function DeleteObject Lib "Gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function DeleteDC Lib "Gdi32" (ByVal hDc As LongPtr) As Long
Private Declare PtrSafe Function BitBlt Lib "Gdi32" (ByVal hDestDC As LongPtr, _
        ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal hSrcDC As LongPtr, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function CLSIDFromString& Lib "ole32" (ByVal lpsz As Any, pclsid As Any)
Private Declare PtrSafe Function OleLoadPicture& Lib "olepro32" (pStream As Any, _
        ByVal lSize&, ByVal fRunmode&, riid As Any, ppvObj As Any)
Private Declare PtrSafe Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As LongPtr, _
        ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare PtrSafe Function GetDIBits Lib "Gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, _
        ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, _
        lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
        
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 POINTAPI
    x As Long
    y As Long
End Type

Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type

Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type

Private Type MemoryBitmap
    hDc As LongPtr
    hbm As LongPtr
    oldhDC As LongPtr
    wID As Long
    hgt As Long
    bitmap_info As BITMAPINFO
End Type

Const WHITE_BRUSH = 0
Const NULL_BRUSH = 5
Const BLACK_PEN = 7
Const BI_RGB = 0&


' Make a memory bitmap of the given size.
' Return the bitmap's DC.
Private Function MakeMemoryBitmap(ByVal wID As Long, ByVal _
    hgt As Long) As MemoryBitmap
    Dim result As MemoryBitmap
    Dim bitmap_info As BITMAPINFO

    ' Create the device context.
    result.hDc = CreateCompatibleDC(0)
  
    ' Create the bitmap.
    result.hbm = CreateCompatibleBitmap(result.hDc, wID, _
        hgt)

    ' Make the device context use the bitmap.
    result.oldhDC = SelectObject(result.hDc, result.hbm)

    ' Return the MemoryBitmap structure.
    result.wID = wID
    result.hgt = hgt
    
    ' set up header.
    With result.bitmap_info.bmiHeader
        .biSize = 40
        .biWidth = wID
        ' Use negative height to scan top-down.
        .biHeight = -hgt
        .biPlanes = 1
        .biBitCount = 32
        .biCompression = BI_RGB
        bytes_per_scanLine = ((((.biWidth * .biBitCount) + _
            31) \ 32) * 4)
        .biSizeImage = bytes_per_scanLine * hgt
    End With

    MakeMemoryBitmap = result
End Function
 
' Draw on the memory bitmap.
Private Sub DrawOnMemoryBitmap(memory_bitmap As _
    MemoryBitmap)
    Dim wID As Long
    Dim hgt As Long

    wID = memory_bitmap.wID
    hgt = memory_bitmap.hgt

    ' Give the device context a white background.
    SelectObject memory_bitmap.hDc, _
        GetStockObject(WHITE_BRUSH)
    Rectangle memory_bitmap.hDc, 0, 0, wID, hgt
    SelectObject memory_bitmap.hDc, _
        GetStockObject(NULL_BRUSH)

    ' Draw the on the device context.
    SelectObject memory_bitmap.hDc, _
        GetStockObject(BLACK_PEN)
    MoveToEx memory_bitmap.hDc, 0, 0, ByVal 0&
    LineTo memory_bitmap.hDc, wID, hgt
    MoveToEx memory_bitmap.hDc, 0, hgt, ByVal 0&
    LineTo memory_bitmap.hDc, wID, 0
End Sub

' Delete the bitmap and free its resources.
Private Sub DeleteMemoryBitmap(memory_bitmap As _
    MemoryBitmap)
    SelectObject memory_bitmap.hDc, memory_bitmap.oldhDC
    DeleteObject memory_bitmap.hbm
    DeleteDC memory_bitmap.hDc
End Sub

' Save the memory bitmap into a bitmap file.
' input is a handle to memory bitmap
Private Sub SaveMemoryBitmap(memory_bitmap As MemoryBitmap, _
    ByVal file_name As String)
    Dim bitmap_file_header As BITMAPFILEHEADER
    Dim fnum As Integer
    Dim pixels() As Byte

    ' Fill in the BITMAPFILEHEADER.
    With bitmap_file_header
        .bfType = &H4D42   ' "BM"
        .bfOffBits = Len(bitmap_file_header) + _
            Len(memory_bitmap.bitmap_info.bmiHeader)
        .bfSize = .bfOffBits + _
            memory_bitmap.bitmap_info.bmiHeader.biSizeImage
    End With

    ' Open the output bitmap file.
    fnum = FreeFile
    Open file_name For Binary As fnum

    ' Write the BITMAPFILEHEADER.
    Put #fnum, , bitmap_file_header

    ' Write the BITMAPINFOHEADER.
    ' (Note that
    ' memory_bitmap.bitmap_info.bmiHeader.biHeight
    ' must be positive for this.)
    Put #fnum, , memory_bitmap.bitmap_info

    ' Get the DIB bits.
    
    ' one D array works fine.
    ReDim pixels(1 To 4 * memory_bitmap.wID * memory_bitmap.hgt)
    
    ' the GetDIBits function retrieves the bits of the specified compatible bitmap
    ' and copies them into a buffer as s DIB using the specified format.
    ' DIB_PAL_COLORS and DIB_RGB_COLORS are two options for GetDIBits.
    
    GetDIBits memory_bitmap.hDc, memory_bitmap.hbm, _
        0, memory_bitmap.hgt, pixels(1), _
        memory_bitmap.bitmap_info, DIB_RGB_COLORS

    ' Write the DIB bits.
    ' use Put no need to worry about space padding.
    ' it seems put will save user defined type without problem.
    ' if you want to use copy memory to work with memory bitmap
    ' it will a pain in the butt.
    Put #fnum, , pixels

    ' Close the file.
    Close fnum
End Sub

Sub Main()
    Dim memory_bitmap As MemoryBitmap
    Dim file_name As String

    ' Create the memory bitmap.
    memory_bitmap = MakeMemoryBitmap(552, 360)

    ' Draw on the bitmap.
    DrawOnMemoryBitmap memory_bitmap

    ' Save the picture.
    file_name = ActiveWorkbook.path
    If Right$(file_name, 1) <> "\" Then file_name = _
        file_name & "\"
    file_name = file_name & "memory_bitmap.bmp"
    SaveMemoryBitmap memory_bitmap, file_name

    ' Delete the memory bitmap.
    DeleteMemoryBitmap memory_bitmap

    MsgBox "Done"
End Sub