Converting RGB Bitmap

[Jazz]

How can I convert RGB Bitmaps to 256 color Mode Bitmap?

...And

Is it possible to change bitmap size without loading them to a picturebox??

[Frans C]

You have to be a bit more precize, because the answer can be pretty complex. Where is your original bitmap located. Is it a .bmp file, or is it stored in a device context in memory(eg on the screen or in a picturebox, or a DC you created yourselve), stored in memory in a DIB structure, or is it loaded from a resource file?

Should the altered bitmap replace the original, or else where do you want to put it? Again the same possibilities.

I would be happy to help you out, but I need a starting point, please let me know.

[Jazz]

It's a Bmp file.

[Frans C]

I wrote some code half a year ago to save a picture from a picturebox as 4 bit bitmap. I changed it a bit so now it saves the picturebox to a 8 bit bitmap. Of course it is possible to read a bitmap file and save it back to disk as a 8 bit bitmap without using a picturebox, but this is the code I have ready at the moment. So load the bitmap in a picturebox, and call the function below to save it.

' example of a function call:
' where Picture1 is the name of a picturebox
Private Sub Command1_Click()
Call Save8bitPicture(Picture1, "C:\temp\test1.bmp")
End Sub


' put this in a module:
Option Explicit
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 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 RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As RGBQUAD '256 colors
End Type
Private Type BITMAPFILEHEADER
bfType(1) As Byte
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type

Private Const BI_RGB = 0&
Private Const GMEM_MOVEABLE = &H2
Private Const DIB_RGB_COLORS = 0

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function lwrite Lib "kernel32" Alias "_lwrite" (ByVal hFile As Long, lpBuffer As Any, ByVal wBytes As Long) As Long
Private Declare Function lclose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long
Private Declare Function lcreat Lib "kernel32" Alias "_lcreat" (ByVal lpPathName As String, ByVal iAttribute As Long) As Long

Public Sub Save8bitPicture(PBox As PictureBox, Dest As String)
Dim tempDC As Long
Dim bm As BITMAP
Dim bi As BITMAPINFO
Dim retVal As Long
Dim bufSize As Long
Dim ghnd As Long
Dim gptr As Long
Dim bmfh As BITMAPFILEHEADER
Dim hFile As Long
Dim Cntr As Integer

' Create a temporary memory DC and select into it
' the background picture of the picture control.
tempDC = CreateCompatibleDC(PBox.hdc)
' Get the size of the picture bitmap
retVal = GetObjectAPI(PBox.Image, Len(bm), bm)
' Fill the BITMAPINFO for the desired DIB
bi.bmiHeader.biSize = Len(bi.bmiHeader)
bi.bmiHeader.biWidth = bm.bmWidth
bi.bmiHeader.biHeight = bm.bmHeight
bi.bmiHeader.biPlanes = 1
' Set to 24 here to create a 24 bit DIB
' Set to 4 here to create an 4 bit DIB
bi.bmiHeader.biBitCount = 8
bi.bmiHeader.biCompression = BI_RGB
' Now calculate the data buffer size needed
bufSize = bi.bmiHeader.biWidth

' Figure out the number of bytes based on the
' number of pixels in each byte. In this case we
' really don't need all this code because this example
' always uses a 255 color DIB, but the code is shown
' here for your future reference
Select Case bi.bmiHeader.biBitCount
Case 1
bufSize = (bufSize + 7) / 8
Case 4
bufSize = (bufSize + 1) / 2
Case 24
bufSize = bufSize * 3
End Select
' And make sure it aligns on a long boundary
bufSize = ((bufSize + 3) / 4) * 4
' And multiply by the # of scan lines
bufSize = bufSize * bi.bmiHeader.biHeight

' Now allocate a buffer to hold the data
' We use the global memory pool because this buffer
' could easily be above 64k bytes.
ghnd = GlobalAlloc(GMEM_MOVEABLE, bufSize)
gptr = GlobalLock(ghnd)

' now copy the picturebox image to the DIB
retVal = GetDIBits(tempDC, PBox.Image, 0, bm.bmHeight, ByVal gptr, bi, DIB_RGB_COLORS)
' write the bitmapfileheader
With bmfh
.bfType(0) = &H42
.bfType(1) = &H4D ' the string "BM", I have split the integer into two bytes because the bytes got swapped
.bfSize = Len(bmfh) + Len(bi) + bufSize
.bfReserved1 = 0
.bfReserved2 = 0
.bfOffBits = Len(bi) + 14
End With

' create the file, I've chosen the api way because
' it's an easy way to copy the data block
hFile = lcreat(Dest, 0)
' write the bitmapfileheader to the file,
' for some strange reasons the structure can't be copied at once
retVal = lwrite(hFile, bmfh.bfType(0), 1)
retVal = lwrite(hFile, bmfh.bfType(1), 1)
retVal = lwrite(hFile, bmfh.bfSize, 4)
retVal = lwrite(hFile, bmfh.bfReserved1, 2)
retVal = lwrite(hFile, bmfh.bfReserved2, 2)
retVal = lwrite(hFile, bmfh.bfOffBits, 4)
' write the bitmapinfo to the file
retVal = lwrite(hFile, bi, Len(bi))
' write the data to the file
retVal = lwrite(hFile, ByVal gptr, bufSize)
' and close the file
retVal = lclose(hFile)
' Dump the global memory block
retVal = GlobalUnlock(ghnd)
retVal = GlobalFree(ghnd)
retVal = DeleteDC(tempDC)
' and were done
End Sub

[Jazz]

T H A N K Y O U ! ! You really helped me!

[sequoyan]

Frans C,

This is great!! I've been looking for something like this for a while now.

Is there anyway to make it work for BMPs in a ListView instead of a picture box?

Thanks alot for posting this.

- Jake

[also, I am trying to test the code you posted but am getting an error: "only comments may appear after End Sub, End Function, or End Property" does the whole thing go in a module? (except for the function call?)]