Как сохранить картинку в файл BMP или байтовый массив из Picture1.hdc

Option Explicit
'//////////////////////////////////////////////////////////
'// Модуль для сохранения картинок в байтовый массив BMP //
'// Copyright (c) 26.01.2025 by HackerVlad               //
'// e-mail: vladislavpeshkov@ya.ru                       //
'// Версия 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

Public Function SimpleSavePicture(pPic As StdPicture) As Byte()
    Dim PB As PropertyBag
    Set PB = New PropertyBag
    PB.WriteProperty "Pic", pPic
    SimpleSavePicture = MidB(PB.Contents, 51)
End Function
    
    ' Потом где-то в коде...
    Dim bArray() As Byte
        
    bArray = SimpleSavePicture(Me.Image)  ' PropertyBag technology

Private Sub Form_Load()
    Me.Picture = Me.Image ' Перефигачить картинку в Picture из JPG в BMP (эту строчку кода можно выполнять только в IDE например, так как в EXE этого глюка Microsoft нету)
End Sub