How to save an image to a BMP byte array with support for 32-bit BMP images on VB6

[HackerVlad]

I have written a module that allows you to save any images to a byte array, represented as a BMP file, which can then, if desired, be saved to disk.

The BMP file is assembled manually, from scratch, with its own code, without using GDIPlusAPI, due to which it should work even in Windows 95.

When saving BMP files, all transparent pixels for 32-bit BMP are taken into account. However, not all viewers support displaying transparency in BMP.

In the test sample program, you can upload a PNG file with support for translucent pixels to a PictureBox and then save it to a 32-bit BMP file.

Also, the SavePictureAsBitmap function presented in this module allows you to convert images into 2-color, 16-color, 256-color files, as well as into 16-bit, 24-bit and 32-bit images.

Option Explicit
'//////////////////////////////////////////////////
'// Module for saving images to a BMP byte array //
'// Copyright (c) 2025-01-26 by HackerVlad       //
'// e-mail: vladislavpeshkov@ya.ru               //
'// Version 1.2                                  //
'//////////////////////////////////////////////////
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hbm As Long, ByVal nStartScan As Long, ByVal cLines As Long, lpvBits As Any, lpbmi As BITMAPINFO, ByVal wUsage 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
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(255) As Long
End Type

Private Type BITMAP
    bmType As Long
    bmWidth As Long ' the width of the bitmap
    bmHeight As Long ' the height of the bitmap
    bmWidthBytes As Long    ' the number of bytes needed to store 1 scanline.
                            ' = bmwidth*(bmBitsPixel/8)+padding bytes (if needed)
    bmPlanes As Integer
    bmBitsPixel As Integer ' the number of bits needed to store the color value of 1 pixel
    bmBits As Long
End Type

Public Enum SetBPP
    NoConvert = 0 ' Save the current picture bitrate
    ConvertTo1bpp = 1 ' 2 colors
    ConvertTo4bpp = 4 ' 16 colors
    ConvertTo8bpp = 8 ' 256 colors
    ConvertTo16bpp = 16
    ConvertTo24bpp = 24
    ConvertTo32bpp = 32
End Enum

' hBitmap is an StdPicture, that is, it can be, for example, Picture1.Picture or Picture1.Image or Image1.Picture
Public Function SavePictureAsBitmap(ByVal hBitmap As Long, BmpFileData() As Byte, Optional ByVal BitsPerPixel As SetBPP) As Boolean
    Dim WidthArray As Long, hdc As Long, ret As Long, ret2 As Long
    Dim bpp As Integer, i As Integer
    Dim FileHeader As BITMAPFILEHEADER
    Dim bInfo As BITMAPINFO
    Dim hBmp As BITMAP
    Dim nCol As Byte
    Dim Palette() As Long
    Dim bArray() As Byte
    
    ' Acceptable BitsPerPixel values: 0 (leave the image without bpp changes), 1 (2 colors), 4 (16 colors), 8 (256 colors), 16, 24, 32
    If BitsPerPixel <> 0 And BitsPerPixel <> 1 And BitsPerPixel <> 4 And BitsPerPixel <> 8 And BitsPerPixel <> 16 And BitsPerPixel <> 24 And BitsPerPixel <> 32 Then Exit Function
    bpp = BitsPerPixel
    
    GetObject hBitmap, LenB(hBmp), hBmp ' We get all the necessary information about the image
    
    If bpp = 0 Then
        bpp = hBmp.bmBitsPixel ' Set the default bits per pixel value for the image
    End If
    
    bInfo.bmiHeader.biHeight = hBmp.bmHeight
    bInfo.bmiHeader.biWidth = hBmp.bmWidth
    bInfo.bmiHeader.biPlanes = hBmp.bmPlanes
    bInfo.bmiHeader.biBitCount = bpp
    bInfo.bmiHeader.biSize = Len(bInfo.bmiHeader)
    
    hdc = GetDC(0) ' We are cheating a little by using the default monitor hDC here
    ret = GetDIBits(hdc, hBitmap, 0, hBmp.bmHeight, ByVal 0&, bInfo, 0)
    
    If ret Then
        WidthArray = bInfo.bmiHeader.biSizeImage / bInfo.bmiHeader.biHeight
        ReDim bArray((WidthArray * bInfo.bmiHeader.biHeight) - 1)
        
        ret2 = GetDIBits(hdc, hBitmap, 0, hBmp.bmHeight, bArray(0), bInfo, 0)
        
        If ret2 Then
            Select Case bpp
                Case 1
                    bInfo.bmiHeader.biClrUsed = 2
                    bInfo.bmiHeader.biClrImportant = 2
                    nCol = 1
                Case 4
                    bInfo.bmiHeader.biClrUsed = 16
                    bInfo.bmiHeader.biClrImportant = 16
                    nCol = 15
                Case 8
                    bInfo.bmiHeader.biClrUsed = 256
                    bInfo.bmiHeader.biClrImportant = 256
                    nCol = 255
                Case 16, 24, 32
                    nCol = 0
            End Select
            
            If nCol > 0 Then ' If a palette is needed
                ReDim Palette(nCol)
                
                For i = 0 To nCol
                    Palette(i) = bInfo.bmiColors(i)
                Next
            End If
            
            FileHeader.bfType = &H4D42 ' BM
            FileHeader.bfOffBits = Len(FileHeader) + Len(bInfo.bmiHeader) + IIf(nCol, (nCol + 1) * 4, 0) ' + palette, if needed
            FileHeader.bfSize = Len(FileHeader) + Len(bInfo.bmiHeader) + IIf(nCol, (nCol + 1) * 4, 0) ' + palette, if needed
            FileHeader.bfSize = FileHeader.bfSize + UBound(bArray) + 1
            
            ReDim BmpFileData(FileHeader.bfSize - 1) ' Allocate memory for a BMP file array
            
            ' We collect a BMP file from various structures
            CopyMemory BmpFileData(0), FileHeader.bfType, 2 ' Write FileHeader (stage 1)
            CopyMemory BmpFileData(2), FileHeader.bfSize, Len(FileHeader) - 2 ' Write FileHeader (stage 2)
            CopyMemory BmpFileData(Len(FileHeader)), bInfo.bmiHeader, Len(bInfo.bmiHeader) ' Write BitmapInfoHeader
            If nCol > 0 Then ' If a palette is needed
                CopyMemory BmpFileData(Len(FileHeader) + Len(bInfo.bmiHeader)), Palette(0), (nCol + 1) * 4 ' Write Palette
            End If
            CopyMemory BmpFileData(FileHeader.bfOffBits), bArray(0), UBound(bArray) + 1 ' Write an array of a bitmap
            
            SavePictureAsBitmap = True
        End If
    End If
    
    ReleaseDC 0, hdc
End Function

[yokesee]

good job

[BenJones]

Thanks for shareing usfull code 5 from me *****

[HackerVlad]

I'm glad to try

[HackerVlad]

Use it to your heart's content!