userFormCreateBMPMemory.vb

' this is a excel vba userform. 
' it has only one image control. 
' this macro will create a bitmap in memroy the hard way.
' filling BitMap header and BitMapinfo manually, then use BitBlt to get pixel to a Bytes array.
' use memorycopy to merge the 3 parts together to a byte array.
' then load the BMP array to to a IPicture interface.
' last step is to load the IPicture to the image control.

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 "oleaut32" (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
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, _
        pSource As Any, ByVal dwLength As Long)
Private Declare PtrSafe Function SetDCBrushColor Lib "Gdi32" (ByVal hDc As LongPtr, ByVal colorref As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    
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 POINTAPI
    x As Long
    y As Long
End Type

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

Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type

Private 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 DC_BRUSH = 18
Const WHITE_BRUSH = 0
Const DKGRAY_BRUSH = 3
Const NULL_BRUSH = 5
Const BLACK_PEN = 7
Const BI_RGB = 0&
Const DIB_RGB_COLORS = 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
    Dim hDc

    ' Create the device context.
    hDc = GetDC(0)
    
    result.hDc = CreateCompatibleDC(hDc)
  
    ' Create the bitmap.
    result.hbm = CreateCompatibleBitmap(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
    
    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.
    With memory_bitmap
        'SelectObject .hdc, GetStockObject(WHITE_BRUSH)
        SelectObject .hDc, GetStockObject(DC_BRUSH)
        SetDCBrushColor .hDc, RGB(100, 0, 0)
        
        Rectangle .hDc, 0, 0, wID, hgt
        SelectObject .hDc, _
        GetStockObject(NULL_BRUSH)
        
        ' Draw the on the device context.
        SelectObject .hDc, _
        GetStockObject(BLACK_PEN)
        MoveToEx .hDc, 0, 0, ByVal 0&
        LineTo .hDc, wID, hgt
        MoveToEx .hDc, 0, hgt, ByVal 0&
        LineTo .hDc, wID, 0
    End With
   
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
 
' byte array to standard image.
' it includes BitMap info and bitmap header as well as the byte array for pixels.

Private Function LoadFromByteStream(B() As Byte) As StdPicture
    ' initiate memory, allocate memory for GUID struct.
    Static IPicture(0 To 15) As Byte
    ' IPicture(0) is pointer to a pre allocated memory.
    ' the Class ID is IPicture Interface, you can also contruct the GUID yourself.
    If IPicture(0) = 0 Then CLSIDFromString StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IPicture(0)
 
    Dim iStream As stdole.IUnknown
    If CreateStreamOnHGlobal(VarPtr(B(LBound(B))), 0, iStream) Then Exit Function
    OleLoadPicture ByVal ObjPtr(iStream), UBound(B) - LBound(B) + 1, 0, IPicture(0), LoadFromByteStream
End Function

' Save the memory bitmap into a bitmap file.
' take handle to bitmap as input.

Private Function SaveMemoryBitmapToByteArray(memory_bitmap As MemoryBitmap)
    Dim bitmap_file_header As BITMAPFILEHEADER
    Dim pixels() As Byte
    Dim fileHeader() As Byte
    Dim fileInfo() As Byte

    ' Fill in the BITMAPFILEHEADER.
    With bitmap_file_header
        .bfType = &H4D42   ' "BM" A little endian uint16_t would see this as 0x4D42
        .bfOffBits = Len(bitmap_file_header) + _
            Len(memory_bitmap.bitmap_info.bmiHeader)
        .bfSize = .bfOffBits + _
            memory_bitmap.bitmap_info.bmiHeader.biSizeImage
    End With

    ' Write the BITMAPFILEHEADER.
    ReDim fileHeader(1 To Len(bitmap_file_header))

    ' this is a way to handle UDT in VBA.
    ' You can't just copythe entire User Defined Type.
    ' It will cause problem.
    
    
    ' int is 2 byte, VBA will add 2 more bytes after it to make it a word
    ' Copy just the first item.
    ' This is an Integer, so only copy 2 bytes...
    CopyMemory fileHeader(1), bitmap_file_header, 2
    ' Copy the rest of the UDT.
    ' The source location is the pointer of the second item (bfSize).
    ' The number of bytes to copy is Len(mBmpFileHeader) minus the
    ' length of bfSize which is 2...
    CopyMemory fileHeader(3), bitmap_file_header.bfSize, Len(bitmap_file_header) - 2

    ' Write the BITMAPINFOHEADER.
    ' (Note that
    ' memory_bitmap.bitmap_info.bmiHeader.biHeight
    ' must be positive for this.)
    ReDim fileInfo(1 To Len(memory_bitmap.bitmap_info))
    CopyMemory fileInfo(1), ByVal memory_bitmap.bitmap_info, Len(memory_bitmap.bitmap_info)

    ' Get the DIB bits.
    ReDim pixels(1 To 4 * memory_bitmap.wID * memory_bitmap.hgt)
    
    GetDIBits memory_bitmap.hDc, memory_bitmap.hbm, _
        0, memory_bitmap.hgt, pixels(1), _
        memory_bitmap.bitmap_info, DIB_RGB_COLORS
    
    ' concatenate byte array
    ' put 3 pieces of memory together.
    
    ConcatenateArrayInPlace fileHeader, fileInfo
    ConcatenateArrayInPlace fileHeader, pixels
    
    fnum = FreeFile
    
    Open ActiveWorkbook.path & "\output.bmp" For Binary As fnum
    Put #fnum, , fileHeader
    Close fnum
    
    SaveMemoryBitmapToByteArray = fileHeader ' this is a byte array.
    
End Function

Public Function GetFileBytes(ByVal path As String) As Byte()
    Dim lngFileNum As Long
    Dim bytRtnVal() As Byte
    lngFileNum = FreeFile
    If LenB(Dir(path)) Then ''// Does file exist?
        Open path For Binary Access Read As lngFileNum
        ReDim bytRtnVal(LOF(lngFileNum) - 1&) As Byte
        Get lngFileNum, , bytRtnVal
        Close lngFileNum
    Else
        Err.Raise 53
    End If
    GetFileBytes = bytRtnVal
    Erase bytRtnVal
End Function

Sub ConcatenateArrayInPlace(ByRef ab1() As Byte, ByRef ab2() As Byte)
    Dim origUBound As Long
    Dim i As Long
    origUBound = UBound(ab1)
    ReDim Preserve ab1(LBound(ab1) To origUBound + 1 + UBound(ab2) - LBound(ab2))
    For i = LBound(ab2) To UBound(ab2)
        ab1(origUBound + 1 + i - LBound(ab2)) = ab2(i)
    Next
End Sub

Private Sub UserForm_Activate()
    AppAddMinimizeMaximizeButton WS_MINIMIZEBOX
    AppAddMinimizeMaximizeButton WS_MAXIMIZEBOX
End Sub

Private Sub userform_initialize()
    Dim memory_bitmap As MemoryBitmap
    
    memory_bitmap = MakeMemoryBitmap( _
        Controls("Image1").Width, _
        Controls("Image1").Height)

    ' Draw on the bitmap.
    DrawOnMemoryBitmap memory_bitmap
    
    ' Copy the device context into the PictureBox.
    ' memory bitmap to byte array
    ' byte array to picture
    With Controls("Image1")
        .PictureSizeMode = fmPictureSizeModeStretch
        .Picture = LoadFromByteStream(SaveMemoryBitmapToByteArray(memory_bitmap))
        '.Picture = Module3.ScreenCapture(x:=0, y:=100, w:=800, h:=800, fname:="D:\myScreenPic.bmp")
    End With
    
    ' display directly on the picture control.
    ' work on this later, draw directly on any control HDC
    'BitBlt Picture1.hdc, 0, 0, _
    '    Picture1.ScaleWidth, _
    '    Picture1.ScaleHeight, _
    '    memory_bitmap.hdc, 0, 0, SRCCOPY
    'Picture1.Picture = Picture1.Image

    ' Delete the memory bitmap.
    DeleteMemoryBitmap memory_bitmap
End Sub