Binaryworld - Load, Modify and Save 1, 4, 8, 15 (Bit-fields), 16, 24 and 32-bit Bitm ... [ VB -> Bitmap ]

This sample code will show you how to load 1, 4, 8, 15 (Bit-fields), 16, 24 and 32-bit images from disk and modify them into memory and save back to disk.

Just copy/paste the following code into form1 code window. Before you run this example make sure that you modify the ImgPath and SavePath.

Click here to copy the following block

Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" ( _
    ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
    ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function LoadImage Lib "User32.dll" Alias "LoadImageA" ( _
    ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, _
    ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function GetObject Lib "GDI32.dll" Alias "GetObjectA" ( _
    ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Function DeleteObject Lib "GDI32.dll" ( _
    ByVal hObject As Long) As Long
Private Declare Function GetDIBits Lib "GDI32.dll" (ByVal aHDC As Long, _
    ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, _
    ByRef lpBits As Any, ByRef lpBI As BitmapInfo8, ByVal wUsage As Long) As Long
Private Declare Function GetDC Lib "User32.dll" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "User32.dll" ( _
    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 SelectObject Lib "GDI32.dll" ( _
    ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "GDI32.dll" ( _
    ByVal hdc As Long) As Long

Private Type Bitmap ' 24 bytes
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Integer
  bmBitsPixel As Integer
  bmBits As Long
End Type

Private Type BitmapFileHeader ' 14 bytes
  bfType As Integer
  bfSize As Long
  bfReserved1 As Integer
  bfReserved2 As Integer
  bfOffBits As Long
End Type

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 BitmapInfo8 ' 1064 bytes
  bmiHeader As BitmapInfoHeader
  bmiColors(255) As Long
End Type

Private Const IMAGE_BITMAP As Long = &H0
Private Const LR_LOADFROMFILE As Long = &H10
Private Const LR_CREATEDIBSECTION As Long = &H2000
Private Const BI_BITFIELDS As Long = &H3

'SET FILE PATH'S HERE THEN REMOVE THIS LINE
Const ImgPath As String = "C:\8bit.bmp"
Const SavePath As String = "C:\save_8bit.bmp"

Private Sub Form_Activate()
  Me.AutoRedraw = True
  Me.PaintPicture LoadPicture(ImgPath), 100, 100
  MsgBox "This is original BMP"

  Me.Cls
  Me.PaintPicture LoadPicture(SavePath), 100, 100
  MsgBox "This is modified BMP"
End Sub

Private Sub Form_Load()
  Dim hBMP As Long, hOldBMP As Long
  Dim hdc As Long

  ' Attempt to load this file from disk
  hBMP = LoadImage(App.hInstance, ImgPath, IMAGE_BITMAP, 0, 0, _
      LR_LOADFROMFILE Or LR_CREATEDIBSECTION)

  If (hBMP) Then  ' Loaded ok, create a DC stick the Bitmap into it
    hdc = CreateCompatibleDC(0)
    hOldBMP = SelectObject(hdc, hBMP)

    ' Perform any drawing to hDC now

    TextOut hdc, 10, 10, "binaryworld.net", Len("binaryworld.net")

    '//Restore old bimap of dc
    Call SelectObject(hdc, hOldBMP)
    Call DeleteDC(hdc)
    ' Attempt to save Bitmap back out to disk
    If (Not SaveDIB(hBMP, SavePath)) Then
      Debug.Print "Error saving """ & SavePath & """"
    End If

    ' Clean up
    Call DeleteObject(hBMP)

  Else  ' Something went wrong during loading
    Debug.Print "Error loading """ & ImgPath & """"
  End If
End Sub

Private Function SaveDIB(ByVal inDIB As Long, ByRef inPath As String) As Boolean
  Dim BMinf As Bitmap
  Dim DIBHead As BitmapInfo8
  Dim NumCols As Long
  Dim DeskDC As Long
  Dim BMData() As Long, DataLen As Long
  Dim FileHead As BitmapFileHeader
  Dim FNum As Integer
  Dim WritePal As Long
  Dim FileSize As Long

  If (GetObject(inDIB, Len(BMinf), BMinf) = 0) Then Exit Function
  If (BMinf.bmBits = 0) Then Exit Function  ' Only working with DIBSection's

  ' Get a reference DC to work with
  DeskDC = GetDC(0)

  ' Set Bitmap info header size
  DIBHead.bmiHeader.biSize = Len(DIBHead.bmiHeader)

  ' Attempt to read DIBSection header
  If (GetDIBits(DeskDC, inDIB, 0, 0, ByVal 0&, DIBHead, 0)) Then
    If (DIBHead.bmiHeader.biBitCount <= 8) Then
      NumCols = DIBHead.bmiHeader.biClrUsed  ' Read palette
      If (NumCols = 0) Then NumCols = 2 ^ DIBHead.bmiHeader.biBitCount
      Call GetDIBits(DeskDC, inDIB, 0, 0, ByVal 0&, DIBHead, 0)
    ElseIf (DIBHead.bmiHeader.biCompression) Then
      If (DIBHead.bmiHeader.biCompression = BI_BITFIELDS) Then
        NumCols = 3
      Else  ' Don't support RLE compressed images
        Call ReleaseDC(0, DeskDC)
        Exit Function
      End If
    End If

    ' Create image data buffer
    DataLen = DIBHead.bmiHeader.biSizeImage \ 4
    ReDim BMData(DataLen - 1) As Long

    ' Read image data
    Call GetDIBits(DeskDC, inDIB, 0, _
        DIBHead.bmiHeader.biHeight, BMData(0), DIBHead, 0)
    DIBHead.bmiHeader.biClrUsed = NumCols

    With FileHead
      .bfType = &H4D42  ' Bitmap magic cookie; ASCII "BM"
      .bfOffBits = Len(FileHead) + Len(DIBHead.bmiHeader) + (NumCols * 4)
      .bfSize = DIBHead.bmiHeader.biSizeImage + .bfOffBits
    End With

    On Error Resume Next  ' Check to see if the file already exists
    FileSize = CBool(FileLen(inPath) + 1)
    On Error GoTo 0

    ' If so, kill it
    If (FileSize) Then Call Kill(inPath)

    FNum = FreeFile()  ' Get a free file handle
    Open inPath For Binary Access Write Lock Read Write As #FNum
    Put #FNum, , FileHead  ' Write file header
    Put #FNum, , DIBHead.bmiHeader  ' Write Bitmap info header

    If (NumCols) Then  ' Write palette
      For WritePal = 0 To NumCols - 1
        Put #FNum, , DIBHead.bmiColors(WritePal)
      Next WritePal
    End If

    Put #FNum, , BMData()  ' Write image data
    Close #FNum

    ' Return true
    SaveDIB = True
  End If

  Call ReleaseDC(0, DeskDC)
End Function