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 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 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 BitmapInfo8 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
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
hBMP = LoadImage(App.hInstance, ImgPath, IMAGE_BITMAP, 0, 0, _ LR_LOADFROMFILE Or LR_CREATEDIBSECTION)
If (hBMP) Then hdc = CreateCompatibleDC(0) hOldBMP = SelectObject(hdc, hBMP)
TextOut hdc, 10, 10, "binaryworld.net", Len("binaryworld.net")
Call SelectObject(hdc, hOldBMP) Call DeleteDC(hdc) If (Not SaveDIB(hBMP, SavePath)) Then Debug.Print "Error saving """ & SavePath & """" End If
Call DeleteObject(hBMP)
Else 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
DeskDC = GetDC(0)
DIBHead.bmiHeader.biSize = Len(DIBHead.bmiHeader)
If (GetDIBits(DeskDC, inDIB, 0, 0, ByVal 0&, DIBHead, 0)) Then If (DIBHead.bmiHeader.biBitCount <= 8) Then NumCols = DIBHead.bmiHeader.biClrUsed 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 Call ReleaseDC(0, DeskDC) Exit Function End If End If
DataLen = DIBHead.bmiHeader.biSizeImage \ 4 ReDim BMData(DataLen - 1) As Long
Call GetDIBits(DeskDC, inDIB, 0, _ DIBHead.bmiHeader.biHeight, BMData(0), DIBHead, 0) DIBHead.bmiHeader.biClrUsed = NumCols
With FileHead .bfType = &H4D42 .bfOffBits = Len(FileHead) + Len(DIBHead.bmiHeader) + (NumCols * 4) .bfSize = DIBHead.bmiHeader.biSizeImage + .bfOffBits End With
On Error Resume Next FileSize = CBool(FileLen(inPath) + 1) On Error GoTo 0
If (FileSize) Then Call Kill(inPath)
FNum = FreeFile() Open inPath For Binary Access Write Lock Read Write As #FNum Put #FNum, , FileHead Put #FNum, , DIBHead.bmiHeader
If (NumCols) Then For WritePal = 0 To NumCols - 1 Put #FNum, , DIBHead.bmiColors(WritePal) Next WritePal End If
Put #FNum, , BMData() Close #FNum
SaveDIB = True End If
Call ReleaseDC(0, DeskDC) End Function |
|