HATCHET
asked on
(100 pts) 24bit BITMAP -> 4 or 8bit
1bit = Black / White
4bit = 16 Color
8bit = 256 Color
24bit = True Color
How do I take a 24bit (default) BITMAP and convert it to 1bit / 4bit / 8bit using the Win32 API?
Thanks,
HATCHET
4bit = 16 Color
8bit = 256 Color
24bit = True Color
How do I take a 24bit (default) BITMAP and convert it to 1bit / 4bit / 8bit using the Win32 API?
Thanks,
HATCHET
ASKER
It's gunna be for display. It doesn't matter if the HBITMAP comes from a file or from a control, etc... as long as I have the hadle to the HBITMAP.
(sigh... the guy that does vbAccelerator is INCREDIBLE at Visual Basic... but it's obvious to see he's obviously a C programmer looking at his code style and finding what you need in his code is like whacking through a rain forest!!)
I'll give it a looksie... thanks for the link.
(sigh... the guy that does vbAccelerator is INCREDIBLE at Visual Basic... but it's obvious to see he's obviously a C programmer looking at his code style and finding what you need in his code is like whacking through a rain forest!!)
I'll give it a looksie... thanks for the link.
ASKER CERTIFIED SOLUTION
membership
Create a free account to see this answer
Signing up is free and takes 30 seconds. No credit card required.
The following lines were got copied in the code by mistake. Sorry. They should be eliminated.
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1, DIB_RGB_COLORS)
SaveBits(), SaveBITMAPINFO_4, DIB_RGB_COLORS)
SaveBits(), SaveBITMAPINFO_8, DIB_RGB_COLORS)
These lines came just before this line:
' Here is where you can customize the foreground and background colors for a 2-color bitmap
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1, DIB_RGB_COLORS)
SaveBits(), SaveBITMAPINFO_4, DIB_RGB_COLORS)
SaveBits(), SaveBITMAPINFO_8, DIB_RGB_COLORS)
These lines came just before this line:
' Here is where you can customize the foreground and background colors for a 2-color bitmap
Sorry, but my proposed answer still has errors in it. This was caused when I pasted my code over and long lines were split into two lines.
PLEASE REJECT MY ANSWER.
I will provide a corrected version if you wish.
This sub requires the bitmap be loaded into a picture box first, but you can hide it by setting its visible property to false.
PLEASE REJECT MY ANSWER.
I will provide a corrected version if you wish.
This sub requires the bitmap be loaded into a picture box first, but you can hide it by setting its visible property to false.
ASKER
MinnEE,
Your code was pass-able... but I didn't user your code per-say. Instead, I studied how you did it, and researched the API calls. In this way, I used your code as a "Template" to create the following code. Because your code was functional and put in on the right track for accomplishing what I needed, I'll give you full credit!
Thanks man! =)
HATCHET
Your code was pass-able... but I didn't user your code per-say. Instead, I studied how you did it, and researched the API calls. In this way, I used your code as a "Template" to create the following code. Because your code was functional and put in on the right track for accomplishing what I needed, I'll give you full credit!
Thanks man! =)
HATCHET
ASKER
Option Explicit
' Type - GetObjectAPI.lpObject
Public Type BITMAP
bmType As Long 'LONG
bmWidth As Long 'LONG
bmHeight As Long 'LONG
bmWidthBytes As Long 'LONG
bmPlanes As Integer 'WORD
bmBitsPixel As Integer 'WORD
bmBits As Long 'LPVOID
End Type
' Type - SavePictureEx
Public Type BITMAPFILEHEADER
bfType As Integer 'WORD
bfSize As Long 'DWORD
bfReserved1 As Integer 'WORD
bfReserved2 As Integer 'WORD
bfOffBits As Long 'DWORD
End Type
' Type - SavePictureEx
Public Type BITMAPINFOHEADER
biSize As Long 'DWORD
biWidth As Long 'LONG
biHeight As Long 'LONG
biPlanes As Integer 'WORD
biBitCount As Integer 'WORD (0,1,4,6,16,24,32)
biCompression As Long 'DWORD (BI_RGB,BI_RLE8,BI_RLE4,BI
biSizeImage As Long 'DWORD
biXPelsPerMeter As Long 'LONG
biYPelsPerMeter As Long 'LONG
biClrUsed As Long 'DWORD
biClrImportant As Long 'DWORD
End Type
' Type - SavePictureEx
Public Type RGBQUAD
rgbBlue As Byte 'BYTE
rgbGreenas As Byte 'BYTE
rgbRedas As Byte 'BYTE
rgbReservedas As Byte 'BYTE
End Type
' Type - SavePictureEx
Public Type BITMAPINFO_1 ' 1 Bit (2 Colors - Monochrome)
bmiHeader As BITMAPINFOHEADER
bmiColors(1) As RGBQUAD
End Type
' Type - SavePictureEx
Public Type BITMAPINFO_4 ' 4 Bits (16 colors)
bmiHeader As BITMAPINFOHEADER
bmiColors(15) As RGBQUAD
End Type
' Type - SavePictureEx
Public Type BITMAPINFO_8 ' 8 Bits (256 colors)
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As RGBQUAD
End Type
' Constants - Color Depths
Public Enum ColorDepths
Color_True = 0 ' 24 Bit Color (Default - This is what VB works with)
Color_256 = 256 ' 8 Bit Color (256 Colors)
Color_16 = 16 ' 4 Bit Color (16 Colors)
Color_2 = 2 ' 1 Bit Color (2 Colors - Monochrome)
End Enum
' Constants - BITMAP.bmType & CopyImage.uType
Public Enum PictureTypes
IMAGE_BITMAP = 0
IMAGE_CURSOR = 1
IMAGE_ICON = 2
IMAGE_ENHMETAFILE = 3
End Enum
' Constants - CopyImage.fuFlags
Public Const LR_COPYDELETEORG = &H8
Public Const LR_COPYFROMRESOURCE = &H4000
Public Const LR_COPYRETURNORG = &H4
Public Const LR_CREATEDIBSECTION = &H2000
Public Const LR_MONOCHROME = &H1
' Constants - BITMAPINFOHEADER.biCompres
Public Const BI_RGB = 0 ' An uncompressed format.
Public Const BI_RLE8 = 1 ' A run-length encoded (RLE) format for bitmaps with 8 bpp.
Public Const BI_RLE4 = 2 ' An RLE format for bitmaps with 4 bpp.
Public Const BI_JPEG = 4 ' Windows 98, Windows 2000: Indicates that the image is a JPEG image.
Public Const BI_PNG = 5 ' Windows 98, Windows 2000: Indicates that the image is a PNG image.
Public Const BI_BITFIELDS = 3 ' Specifies that the bitmap is not compressed and that the
' color table consists of three DWORD color masks that specify
' the red, green, and blue components, respectively, of each pixel.
' This is valid when used with 16-bpp and 32-bpp bitmaps.
' Constants - GetDIBits.uUsage (RGB_or_PAL)
Public Const DIB_RGB_COLORS = 0 ' The color table should consist of an array of 16-bit
' indexes into the current logical palette.
Public Const DIB_PAL_COLORS = 1 ' The color table should consist of literal red, green,
' blue (RGB) values.
' Win32 API Declarations
Public Declare Function CopyImage Lib "USER32" (ByVal hImage As Long, _
ByVal uType As Long, _
ByVal OutputWidth As Long, _
ByVal OutputHeight As Long, _
ByVal fuFlags As Long) As Long
Public Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long
Public Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long
Public Declare Function DeleteObject Lib "GDI32" (ByVal hGDIObj As Long) As Long
Public Declare Function GetDesktopWindow Lib "USER32" () As Long
Public Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Public Declare Function GetDIBits Lib "GDI32" (ByVal hDC As Long, _
ByVal hBITMAP As Long, _
ByVal FirstScanLine As Long, _
ByVal ScanLineCount As Long, _
ByRef Return_BitmapData As Any, _
ByRef lpBITMAPINFO As Any, _
ByVal RGB_or_PAL As Long) As Long
Public Declare Function GetObjectAPI Lib "GDI32" Alias "GetObjectA" (ByVal hObject As Long, _
ByVal nCount As Long, _
ByRef lpObject As Any) As Long
Public Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Public Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hGDIObj As Long) As Long
'=========================
'
' SavePictureEx
'
' This function allows you to save a BITMAP picture in several different color depths. Saving an
' image in a lower color depth will make the save file smaller, but will reduce the image quality.
'
' Parameter: Use:
' --------------------------
' Picture_BMP Specifies the handle to the BITMAP image to save
' FileName Specifies the full path of the file to save the image to
' ColorDepth Specifies the color depth of the saved image (Monochrome, 16 colors,
' 256 colors, or "True Color" (24 Bit Color).
' PromptToOverwrite If set to TRUE and the file specified in the "FileName" parameter exists,
' the user will be prompted to overwrite the existing file. If set to
' FALSE and the file already exists, the file is deleted before the new
' one is saved out.
'
' Example Use:
' ------------
' SavePictureEx Picture1.Picture, "C:\TEST.BMP", Color_256, True
'
' Return:
' -------
' If the function succeeds, the return is TRUE
' If the function fails, the return is FALSE
'
'=========================
Public Function SavePictureEx(ByRef Picture_BMP As StdPicture, _
ByVal FileName As String, _
Optional ByVal ColorDepth As ColorDepths = Color_True, _
Optional ByVal PromptToOverwrite As Boolean = True) As Boolean
On Error Resume Next
Dim PicInfo As BITMAP
Dim PicHeaderInfo As BITMAPFILEHEADER
Dim PicBMPINFO_1 As BITMAPINFO_1
Dim PicBMPINFO_4 As BITMAPINFO_4
Dim PicBMPINFO_8 As BITMAPINFO_8
Dim PicBits() As Byte
Dim PicHeight As Long
Dim PicWidth As Long
Dim PicBitsPerPixel As Integer
Dim PicSize As Long
Dim PicScanLineSize As Long
Dim PicBmpInfoSize As Long
Dim FileNum As Integer
Dim hDC_Screen As Long
Dim hDC_Temp As Long
Dim hBMP_Pic As Long
Dim hBMP_Prev As Long
Dim ReturnValue As Long
' Make sure the parameters passed are valid
FileName = Trim(FileName)
If FileName = "" Then Exit Function
If Picture_BMP Is Nothing Then Exit Function
If Picture_BMP.Type <> vbPicTypeBitmap Then Exit Function
' Get the picture's dimentions (this also checks to make sure that the picture is a BITMAP)
If GetObjectAPI(Picture_BMP.H
PicHeight = PicInfo.bmHeight
PicWidth = PicInfo.bmWidth
' If the color depth is "True Color", then use the VB function
' "SavePicture" because it uses "True Color" to save
Select Case ColorDepth
Case Color_True
GoSub CheckIfFileExists
SavePicture Picture_BMP, FileName
SavePictureEx = True
Exit Function
Case Color_256
PicBitsPerPixel = 8
Case Color_16
PicBitsPerPixel = 4
Case Color_2
PicBitsPerPixel = 1
End Select
' Calculate the size of one scan line (this is multiplied by the height to
' get the size of the bitmap data
PicScanLineSize = (PicWidth * PicBitsPerPixel) \ 32
' End each scan line on 32-bit boundary
If PicWidth Mod 32 > 0 Then PicScanLineSize = PicScanLineSize + 1
' Scan Line Size * 4 (for RGB size) * Height = Buffer Size
PicSize = PicScanLineSize * 4 * PicHeight
' Create a DC to work with
hDC_Screen = GetDC(GetDesktopWindow)
If hDC_Screen = 0 Then Exit Function
hDC_Temp = CreateCompatibleDC(hDC_Scr
ReleaseDC GetDesktopWindow, hDC_Screen: hDC_Screen = 0
If hDC_Temp = 0 Then Exit Function
' Make a copy of the original picture so we don't mess up the original
If ColorDepth = Color_2 Then
hBMP_Pic = CopyImage(Picture_BMP.Hand
Else
hBMP_Pic = CopyImage(Picture_BMP.Hand
End If
If hBMP_Pic = 0 Then GoTo CleanUp
' Select the picture into the DC to work with
hBMP_Prev = SelectObject(hDC_Temp, hBMP_Pic)
' Create a buffer for the BITMAP data (bits) to be placed in
ReDim PicBits(0 To PicSize - 1) As Byte
' Fill the bitmap info according to the color depth
Select Case PicBitsPerPixel
Case 1
PicBmpInfoSize = Len(PicBMPINFO_1)
With PicBMPINFO_1
.bmiHeader.biSize = PicBmpInfoSize
.bmiHeader.biWidth = PicWidth
.bmiHeader.biHeight = PicHeight
.bmiHeader.biPlanes = 1
.bmiHeader.biBitCount = PicBitsPerPixel
.bmiHeader.biCompression = BI_RGB
.bmiHeader.biSizeImage = PicSize
.bmiHeader.biXPelsPerMeter
.bmiHeader.biYPelsPerMeter
.bmiHeader.biClrUsed = 0 ' Specifies Use All
.bmiHeader.biClrImportant = 0 ' Specifies All Are Required
End With
If GetDIBits(hDC_Temp, hBMP_Pic, 0, PicHeight, PicBits(0), _
PicBMPINFO_1, DIB_RGB_COLORS) = 0 Then GoTo CleanUp
Case 4
PicBmpInfoSize = Len(PicBMPINFO_4)
With PicBMPINFO_4
.bmiHeader.biSize = PicBmpInfoSize
.bmiHeader.biWidth = PicWidth
.bmiHeader.biHeight = PicHeight
.bmiHeader.biPlanes = 1
.bmiHeader.biBitCount = PicBitsPerPixel
.bmiHeader.biCompression = BI_RGB
.bmiHeader.biSizeImage = PicSize
.bmiHeader.biXPelsPerMeter
.bmiHeader.biYPelsPerMeter
.bmiHeader.biClrUsed = 0 ' Specifies Use All
.bmiHeader.biClrImportant = 0 ' Specifies All Are Required
End With
If GetDIBits(hDC_Temp, hBMP_Pic, 0, PicHeight, PicBits(0), _
PicBMPINFO_4, DIB_RGB_COLORS) = 0 Then GoTo CleanUp
Case 8
PicBmpInfoSize = Len(PicBMPINFO_8)
With PicBMPINFO_8
.bmiHeader.biSize = PicBmpInfoSize
.bmiHeader.biWidth = PicWidth
.bmiHeader.biHeight = PicHeight
.bmiHeader.biPlanes = 1
.bmiHeader.biBitCount = PicBitsPerPixel
.bmiHeader.biCompression = BI_RGB
.bmiHeader.biSizeImage = PicSize
.bmiHeader.biXPelsPerMeter
.bmiHeader.biYPelsPerMeter
.bmiHeader.biClrUsed = 0 ' Specifies Use All
.bmiHeader.biClrImportant = 0 ' Specifies All Are Required
End With
If GetDIBits(hDC_Temp, hBMP_Pic, 0, PicHeight, PicBits(0), _
PicBMPINFO_8, DIB_RGB_COLORS) = 0 Then GoTo CleanUp
End Select
' Create the bitmap header to be writen out
With PicHeaderInfo
.bfType = &H4D42 ' Specifies the file type, must be "BM"
.bfSize = Len(PicHeaderInfo) + PicBmpInfoSize + PicSize
.bfOffBits = Len(PicHeaderInfo) + PicBmpInfoSize
End With
GoSub CheckIfFileExists
' Save out the picture
FileNum = FreeFile
Open FileName For Binary As FileNum
Put FileNum, , PicHeaderInfo
If PicBitsPerPixel = 1 Then Put FileNum, , PicBMPINFO_1
If PicBitsPerPixel = 4 Then Put FileNum, , PicBMPINFO_4
If PicBitsPerPixel = 8 Then Put FileNum, , PicBMPINFO_8
Put FileNum, , PicBits()
Close FileNum
SavePictureEx = True
CleanUp:
' Cleanup the meory used by this function
If hDC_Temp <> 0 Then
SelectObject hDC_Temp, hBMP_Prev
DeleteDC hDC_Temp: hDC_Temp = 0
DeleteObject hBMP_Pic: hBMP_Pic = 0
hBMP_Prev = 0
End If
Exit Function
CheckIfFileExists:
' Check if the file already exists, and if it does, prompt to overwrite it
If Dir(FileName) <> "" Then
If PromptToOverwrite = True Then
If MsgBox(FileName & Chr(13) & "This file already exists." & Chr(13) & Chr(13) & _
"Replace existing file?", vbYesNo + vbExclamation, _
" Confirm File Overwrite") <> vbYes Then
SavePictureEx = True
GoTo CleanUp
Else
Kill FileName
End If
Else
Kill FileName
End If
End If
Return
End Function
' Type - GetObjectAPI.lpObject
Public Type BITMAP
bmType As Long 'LONG
bmWidth As Long 'LONG
bmHeight As Long 'LONG
bmWidthBytes As Long 'LONG
bmPlanes As Integer 'WORD
bmBitsPixel As Integer 'WORD
bmBits As Long 'LPVOID
End Type
' Type - SavePictureEx
Public Type BITMAPFILEHEADER
bfType As Integer 'WORD
bfSize As Long 'DWORD
bfReserved1 As Integer 'WORD
bfReserved2 As Integer 'WORD
bfOffBits As Long 'DWORD
End Type
' Type - SavePictureEx
Public Type BITMAPINFOHEADER
biSize As Long 'DWORD
biWidth As Long 'LONG
biHeight As Long 'LONG
biPlanes As Integer 'WORD
biBitCount As Integer 'WORD (0,1,4,6,16,24,32)
biCompression As Long 'DWORD (BI_RGB,BI_RLE8,BI_RLE4,BI
biSizeImage As Long 'DWORD
biXPelsPerMeter As Long 'LONG
biYPelsPerMeter As Long 'LONG
biClrUsed As Long 'DWORD
biClrImportant As Long 'DWORD
End Type
' Type - SavePictureEx
Public Type RGBQUAD
rgbBlue As Byte 'BYTE
rgbGreenas As Byte 'BYTE
rgbRedas As Byte 'BYTE
rgbReservedas As Byte 'BYTE
End Type
' Type - SavePictureEx
Public Type BITMAPINFO_1 ' 1 Bit (2 Colors - Monochrome)
bmiHeader As BITMAPINFOHEADER
bmiColors(1) As RGBQUAD
End Type
' Type - SavePictureEx
Public Type BITMAPINFO_4 ' 4 Bits (16 colors)
bmiHeader As BITMAPINFOHEADER
bmiColors(15) As RGBQUAD
End Type
' Type - SavePictureEx
Public Type BITMAPINFO_8 ' 8 Bits (256 colors)
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As RGBQUAD
End Type
' Constants - Color Depths
Public Enum ColorDepths
Color_True = 0 ' 24 Bit Color (Default - This is what VB works with)
Color_256 = 256 ' 8 Bit Color (256 Colors)
Color_16 = 16 ' 4 Bit Color (16 Colors)
Color_2 = 2 ' 1 Bit Color (2 Colors - Monochrome)
End Enum
' Constants - BITMAP.bmType & CopyImage.uType
Public Enum PictureTypes
IMAGE_BITMAP = 0
IMAGE_CURSOR = 1
IMAGE_ICON = 2
IMAGE_ENHMETAFILE = 3
End Enum
' Constants - CopyImage.fuFlags
Public Const LR_COPYDELETEORG = &H8
Public Const LR_COPYFROMRESOURCE = &H4000
Public Const LR_COPYRETURNORG = &H4
Public Const LR_CREATEDIBSECTION = &H2000
Public Const LR_MONOCHROME = &H1
' Constants - BITMAPINFOHEADER.biCompres
Public Const BI_RGB = 0 ' An uncompressed format.
Public Const BI_RLE8 = 1 ' A run-length encoded (RLE) format for bitmaps with 8 bpp.
Public Const BI_RLE4 = 2 ' An RLE format for bitmaps with 4 bpp.
Public Const BI_JPEG = 4 ' Windows 98, Windows 2000: Indicates that the image is a JPEG image.
Public Const BI_PNG = 5 ' Windows 98, Windows 2000: Indicates that the image is a PNG image.
Public Const BI_BITFIELDS = 3 ' Specifies that the bitmap is not compressed and that the
' color table consists of three DWORD color masks that specify
' the red, green, and blue components, respectively, of each pixel.
' This is valid when used with 16-bpp and 32-bpp bitmaps.
' Constants - GetDIBits.uUsage (RGB_or_PAL)
Public Const DIB_RGB_COLORS = 0 ' The color table should consist of an array of 16-bit
' indexes into the current logical palette.
Public Const DIB_PAL_COLORS = 1 ' The color table should consist of literal red, green,
' blue (RGB) values.
' Win32 API Declarations
Public Declare Function CopyImage Lib "USER32" (ByVal hImage As Long, _
ByVal uType As Long, _
ByVal OutputWidth As Long, _
ByVal OutputHeight As Long, _
ByVal fuFlags As Long) As Long
Public Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long
Public Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long
Public Declare Function DeleteObject Lib "GDI32" (ByVal hGDIObj As Long) As Long
Public Declare Function GetDesktopWindow Lib "USER32" () As Long
Public Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Public Declare Function GetDIBits Lib "GDI32" (ByVal hDC As Long, _
ByVal hBITMAP As Long, _
ByVal FirstScanLine As Long, _
ByVal ScanLineCount As Long, _
ByRef Return_BitmapData As Any, _
ByRef lpBITMAPINFO As Any, _
ByVal RGB_or_PAL As Long) As Long
Public Declare Function GetObjectAPI Lib "GDI32" Alias "GetObjectA" (ByVal hObject As Long, _
ByVal nCount As Long, _
ByRef lpObject As Any) As Long
Public Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Public Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hGDIObj As Long) As Long
'=========================
'
' SavePictureEx
'
' This function allows you to save a BITMAP picture in several different color depths. Saving an
' image in a lower color depth will make the save file smaller, but will reduce the image quality.
'
' Parameter: Use:
' --------------------------
' Picture_BMP Specifies the handle to the BITMAP image to save
' FileName Specifies the full path of the file to save the image to
' ColorDepth Specifies the color depth of the saved image (Monochrome, 16 colors,
' 256 colors, or "True Color" (24 Bit Color).
' PromptToOverwrite If set to TRUE and the file specified in the "FileName" parameter exists,
' the user will be prompted to overwrite the existing file. If set to
' FALSE and the file already exists, the file is deleted before the new
' one is saved out.
'
' Example Use:
' ------------
' SavePictureEx Picture1.Picture, "C:\TEST.BMP", Color_256, True
'
' Return:
' -------
' If the function succeeds, the return is TRUE
' If the function fails, the return is FALSE
'
'=========================
Public Function SavePictureEx(ByRef Picture_BMP As StdPicture, _
ByVal FileName As String, _
Optional ByVal ColorDepth As ColorDepths = Color_True, _
Optional ByVal PromptToOverwrite As Boolean = True) As Boolean
On Error Resume Next
Dim PicInfo As BITMAP
Dim PicHeaderInfo As BITMAPFILEHEADER
Dim PicBMPINFO_1 As BITMAPINFO_1
Dim PicBMPINFO_4 As BITMAPINFO_4
Dim PicBMPINFO_8 As BITMAPINFO_8
Dim PicBits() As Byte
Dim PicHeight As Long
Dim PicWidth As Long
Dim PicBitsPerPixel As Integer
Dim PicSize As Long
Dim PicScanLineSize As Long
Dim PicBmpInfoSize As Long
Dim FileNum As Integer
Dim hDC_Screen As Long
Dim hDC_Temp As Long
Dim hBMP_Pic As Long
Dim hBMP_Prev As Long
Dim ReturnValue As Long
' Make sure the parameters passed are valid
FileName = Trim(FileName)
If FileName = "" Then Exit Function
If Picture_BMP Is Nothing Then Exit Function
If Picture_BMP.Type <> vbPicTypeBitmap Then Exit Function
' Get the picture's dimentions (this also checks to make sure that the picture is a BITMAP)
If GetObjectAPI(Picture_BMP.H
PicHeight = PicInfo.bmHeight
PicWidth = PicInfo.bmWidth
' If the color depth is "True Color", then use the VB function
' "SavePicture" because it uses "True Color" to save
Select Case ColorDepth
Case Color_True
GoSub CheckIfFileExists
SavePicture Picture_BMP, FileName
SavePictureEx = True
Exit Function
Case Color_256
PicBitsPerPixel = 8
Case Color_16
PicBitsPerPixel = 4
Case Color_2
PicBitsPerPixel = 1
End Select
' Calculate the size of one scan line (this is multiplied by the height to
' get the size of the bitmap data
PicScanLineSize = (PicWidth * PicBitsPerPixel) \ 32
' End each scan line on 32-bit boundary
If PicWidth Mod 32 > 0 Then PicScanLineSize = PicScanLineSize + 1
' Scan Line Size * 4 (for RGB size) * Height = Buffer Size
PicSize = PicScanLineSize * 4 * PicHeight
' Create a DC to work with
hDC_Screen = GetDC(GetDesktopWindow)
If hDC_Screen = 0 Then Exit Function
hDC_Temp = CreateCompatibleDC(hDC_Scr
ReleaseDC GetDesktopWindow, hDC_Screen: hDC_Screen = 0
If hDC_Temp = 0 Then Exit Function
' Make a copy of the original picture so we don't mess up the original
If ColorDepth = Color_2 Then
hBMP_Pic = CopyImage(Picture_BMP.Hand
Else
hBMP_Pic = CopyImage(Picture_BMP.Hand
End If
If hBMP_Pic = 0 Then GoTo CleanUp
' Select the picture into the DC to work with
hBMP_Prev = SelectObject(hDC_Temp, hBMP_Pic)
' Create a buffer for the BITMAP data (bits) to be placed in
ReDim PicBits(0 To PicSize - 1) As Byte
' Fill the bitmap info according to the color depth
Select Case PicBitsPerPixel
Case 1
PicBmpInfoSize = Len(PicBMPINFO_1)
With PicBMPINFO_1
.bmiHeader.biSize = PicBmpInfoSize
.bmiHeader.biWidth = PicWidth
.bmiHeader.biHeight = PicHeight
.bmiHeader.biPlanes = 1
.bmiHeader.biBitCount = PicBitsPerPixel
.bmiHeader.biCompression = BI_RGB
.bmiHeader.biSizeImage = PicSize
.bmiHeader.biXPelsPerMeter
.bmiHeader.biYPelsPerMeter
.bmiHeader.biClrUsed = 0 ' Specifies Use All
.bmiHeader.biClrImportant = 0 ' Specifies All Are Required
End With
If GetDIBits(hDC_Temp, hBMP_Pic, 0, PicHeight, PicBits(0), _
PicBMPINFO_1, DIB_RGB_COLORS) = 0 Then GoTo CleanUp
Case 4
PicBmpInfoSize = Len(PicBMPINFO_4)
With PicBMPINFO_4
.bmiHeader.biSize = PicBmpInfoSize
.bmiHeader.biWidth = PicWidth
.bmiHeader.biHeight = PicHeight
.bmiHeader.biPlanes = 1
.bmiHeader.biBitCount = PicBitsPerPixel
.bmiHeader.biCompression = BI_RGB
.bmiHeader.biSizeImage = PicSize
.bmiHeader.biXPelsPerMeter
.bmiHeader.biYPelsPerMeter
.bmiHeader.biClrUsed = 0 ' Specifies Use All
.bmiHeader.biClrImportant = 0 ' Specifies All Are Required
End With
If GetDIBits(hDC_Temp, hBMP_Pic, 0, PicHeight, PicBits(0), _
PicBMPINFO_4, DIB_RGB_COLORS) = 0 Then GoTo CleanUp
Case 8
PicBmpInfoSize = Len(PicBMPINFO_8)
With PicBMPINFO_8
.bmiHeader.biSize = PicBmpInfoSize
.bmiHeader.biWidth = PicWidth
.bmiHeader.biHeight = PicHeight
.bmiHeader.biPlanes = 1
.bmiHeader.biBitCount = PicBitsPerPixel
.bmiHeader.biCompression = BI_RGB
.bmiHeader.biSizeImage = PicSize
.bmiHeader.biXPelsPerMeter
.bmiHeader.biYPelsPerMeter
.bmiHeader.biClrUsed = 0 ' Specifies Use All
.bmiHeader.biClrImportant = 0 ' Specifies All Are Required
End With
If GetDIBits(hDC_Temp, hBMP_Pic, 0, PicHeight, PicBits(0), _
PicBMPINFO_8, DIB_RGB_COLORS) = 0 Then GoTo CleanUp
End Select
' Create the bitmap header to be writen out
With PicHeaderInfo
.bfType = &H4D42 ' Specifies the file type, must be "BM"
.bfSize = Len(PicHeaderInfo) + PicBmpInfoSize + PicSize
.bfOffBits = Len(PicHeaderInfo) + PicBmpInfoSize
End With
GoSub CheckIfFileExists
' Save out the picture
FileNum = FreeFile
Open FileName For Binary As FileNum
Put FileNum, , PicHeaderInfo
If PicBitsPerPixel = 1 Then Put FileNum, , PicBMPINFO_1
If PicBitsPerPixel = 4 Then Put FileNum, , PicBMPINFO_4
If PicBitsPerPixel = 8 Then Put FileNum, , PicBMPINFO_8
Put FileNum, , PicBits()
Close FileNum
SavePictureEx = True
CleanUp:
' Cleanup the meory used by this function
If hDC_Temp <> 0 Then
SelectObject hDC_Temp, hBMP_Prev
DeleteDC hDC_Temp: hDC_Temp = 0
DeleteObject hBMP_Pic: hBMP_Pic = 0
hBMP_Prev = 0
End If
Exit Function
CheckIfFileExists:
' Check if the file already exists, and if it does, prompt to overwrite it
If Dir(FileName) <> "" Then
If PromptToOverwrite = True Then
If MsgBox(FileName & Chr(13) & "This file already exists." & Chr(13) & Chr(13) & _
"Replace existing file?", vbYesNo + vbExclamation, _
" Confirm File Overwrite") <> vbYes Then
SavePictureEx = True
GoTo CleanUp
Else
Kill FileName
End If
Else
Kill FileName
End If
End If
Return
End Function
Good work Hatchet! Your's is better documented.
For the record, here is what I intended to show:
' *** Declares needed by this sub:
Type BITMAPFILEHEADER '14 Bytes
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
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 RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Type BITMAPINFO_1 ' For monochrome
bmiHeader As BITMAPINFOHEADER
bmiColors(1) As RGBQUAD
End Type
Type BITMAPINFO_4 ' For 4 bits per pixel (16 colors)
bmiHeader As BITMAPINFOHEADER
bmiColors(15) As RGBQUAD
End Type
Type BITMAPINFO_8 ' For 8 bits per pixel (256 colors)
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As RGBQUAD
End Type
' Following Declares must be on one line:
Declare Function GetDIBits Lib "GDI32" (ByVal aHDC&, ByVal hBitmap, ByVal nStartScan&, ByVal nNumScans&, ByVal LpBits As Any, lpBI As BITMAPINFO_1, ByVal wUsage&) As Long
Declare Function GetDIBits1 Lib "GDI32" Alias "GetDIBits" (ByVal aHDC&, ByVal hBitmap&, ByVal nStartScan&, ByVal nNumScans&, LpBits As Any, lpBI As BITMAPINFO_1, ByVal wUsage&) As Long
Declare Function GetDIBits4 Lib "GDI32" Alias "GetDIBits" (ByVal aHDC&, ByVal hBitmap&, ByVal nStartScan&, ByVal nNumScans&, LpBits As Any, lpBI As BITMAPINFO_4, ByVal wUsage&) As Long
Declare Function GetDIBits8 Lib "GDI32" Alias "GetDIBits" (ByVal aHDC&, ByVal hBitmap&, ByVal nStartScan&, ByVal nNumScans&, LpBits As Any, lpBI As BITMAPINFO_8, ByVal wUsage&) As Long
Sub SaveNewBMP(pic As PictureBox, FileName As String, ByVal NumColors As Integer)
' For VB5 and VB6 (32 bit)
' Save picture box at reduced color depth bitmap to reduce file size when full color is not 'needed.
' NumColors can be either:
' 2, 16, 256 for the number of colors, or
' 1, 4, 8 for the number color bits (bits per pixel.
' Has provision to customize foreground and background colors in 2-color version
' ** Note: this SUB sets the source picturebox to scalemode 3 (pixels).
' Restore scalemode and any custom scale properties if you may
' add more graphics or print to the picture box.
'
' Type definitions and declarations needed for this sub are shown above
'
' Programmer = Dick Petschauer; RJPetsch@Aol.com Apr, 1999
' Tested a little. Not gauranteed to be bug free.
Dim SaveFileHeader As BITMAPFILEHEADER
Dim SaveBITMAPINFO_1 As BITMAPINFO_1
Dim SaveBITMAPINFO_4 As BITMAPINFO_4
Dim SaveBITMAPINFO_8 As BITMAPINFO_8
Dim SaveBits() As Byte
Dim BitsPerPixel As Integer
Dim Num32bitWords As Integer
Dim Buffersize As Long
Dim FileNum As Integer
Dim Retval& ' Temporary returns and handles follow
' Set the Scalemode to pixels (*** Note: this also sets the source picturebox to scalemode 3)
pic.ScaleMode = 3 ' Pixels
' Allow for use of color bits to be used instead of the number of colors:
If NumColors = 1 Then NumColors = 2
If NumColors = 4 Then NumColors = 16
If NumColors = 8 Then NumColors = 256
' Check for illegal NumColors. Set to default as monochrome.
If NumColors <> 2 And NumColors <> 16 And NumColors <> 256 Then NumColors = 2
BitsPerPixel = Log(NumColors) / Log(2)
' *** Calculate the buffer for the pixel data
Num32bitWords = (pic.ScaleWidth * BitsPerPixel) \ 32 ' Integer divide
If pic.ScaleWidth Mod 32 > 0 Then Num32bitWords = Num32bitWords + 1 ' End each scan line on '32-bit boundary
Buffersize = Num32bitWords * 4 * pic.ScaleHeight ' 8-bit Bytes; 8 pixels per byte for mono; 2 'for 16 color; 4 for 256 color
' Buffersize can be larger than this; results in larger bitmap file.
ReDim SaveBits(0 To Buffersize - 1)
Debug.Print Buffersize; UBound(SaveBits)
' *** Fill the Bitmap info
If BitsPerPixel = 1 Then
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
End If
If BitsPerPixel = 4 Then
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
End If
If BitsPerPixel = 8 Then
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
End If
' Following Code each on one line (3 occurrances)
If BitsPerPixel = 1 Then Retval& = GetDIBits1(pic.hDC, pic.Image, 0, pic.ScaleHeight, SaveBits(0), SaveBITMAPINFO_1, DIB_RGB_COLORS)
If BitsPerPixel = 4 Then Retval& = GetDIBits4(pic.hDC, pic.Image, 0, pic.ScaleHeight, SaveBits(0), SaveBITMAPINFO_4, DIB_RGB_COLORS)
If BitsPerPixel = 8 Then Retval& = GetDIBits8(pic.hDC, pic.Image, 0, pic.ScaleHeight, SaveBits(0), SaveBITMAPINFO_8, DIB_RGB_COLORS)
If BitsPerPixel = 1 Then BiLen = Len(SaveBITMAPINFO_1)
If BitsPerPixel = 4 Then BiLen = Len(SaveBITMAPINFO_4)
If BitsPerPixel = 8 Then BiLen = Len(SaveBITMAPINFO_8)
' *** Make and fill a Header for the new bitmap
SaveFileHeader.bfType = &H4D42 ' "BM" for Bitmap; first two characters in file
SaveFileHeader.bfSize = Len(SaveFileHeader) + BiLen + Buffersize
SaveFileHeader.bfOffBits = Len(SaveFileHeader) + BiLen
' Here is where you can customize the foreground and background colors for a 2-color bitmap
' For the Foreground color add this line:
' Mid$(SaveBITMAPINFO_1.bmiC
' For the Foreground color add this line:
' Mid$(SaveBITMAPINFO_1.bmiC
' Where ForeBlue, etc are integers from 0 to 255 that represent the respective color strength.
' For white, set all to 255; Black all to 0.
' Defaults: Black foreground, White background.
' *** Save the Bitmap Header and BitmapInfo to disk
' First remove old bitmap file if there
If Dir$(FileName) <> "" Then Kill FileName
FileNum = FreeFile
Open FileName For Binary As FileNum
Put FileNum, , SaveFileHeader
If BitsPerPixel = 1 Then Put FileNum, , SaveBITMAPINFO_1
If BitsPerPixel = 4 Then Put FileNum, , SaveBITMAPINFO_4
If BitsPerPixel = 8 Then Put FileNum, , SaveBITMAPINFO_8
Put FileNum, , SaveBits()
Close FileNum
End Sub
For the record, here is what I intended to show:
' *** Declares needed by this sub:
Type BITMAPFILEHEADER '14 Bytes
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type
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 RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Type BITMAPINFO_1 ' For monochrome
bmiHeader As BITMAPINFOHEADER
bmiColors(1) As RGBQUAD
End Type
Type BITMAPINFO_4 ' For 4 bits per pixel (16 colors)
bmiHeader As BITMAPINFOHEADER
bmiColors(15) As RGBQUAD
End Type
Type BITMAPINFO_8 ' For 8 bits per pixel (256 colors)
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As RGBQUAD
End Type
' Following Declares must be on one line:
Declare Function GetDIBits Lib "GDI32" (ByVal aHDC&, ByVal hBitmap, ByVal nStartScan&, ByVal nNumScans&, ByVal LpBits As Any, lpBI As BITMAPINFO_1, ByVal wUsage&) As Long
Declare Function GetDIBits1 Lib "GDI32" Alias "GetDIBits" (ByVal aHDC&, ByVal hBitmap&, ByVal nStartScan&, ByVal nNumScans&, LpBits As Any, lpBI As BITMAPINFO_1, ByVal wUsage&) As Long
Declare Function GetDIBits4 Lib "GDI32" Alias "GetDIBits" (ByVal aHDC&, ByVal hBitmap&, ByVal nStartScan&, ByVal nNumScans&, LpBits As Any, lpBI As BITMAPINFO_4, ByVal wUsage&) As Long
Declare Function GetDIBits8 Lib "GDI32" Alias "GetDIBits" (ByVal aHDC&, ByVal hBitmap&, ByVal nStartScan&, ByVal nNumScans&, LpBits As Any, lpBI As BITMAPINFO_8, ByVal wUsage&) As Long
Sub SaveNewBMP(pic As PictureBox, FileName As String, ByVal NumColors As Integer)
' For VB5 and VB6 (32 bit)
' Save picture box at reduced color depth bitmap to reduce file size when full color is not 'needed.
' NumColors can be either:
' 2, 16, 256 for the number of colors, or
' 1, 4, 8 for the number color bits (bits per pixel.
' Has provision to customize foreground and background colors in 2-color version
' ** Note: this SUB sets the source picturebox to scalemode 3 (pixels).
' Restore scalemode and any custom scale properties if you may
' add more graphics or print to the picture box.
'
' Type definitions and declarations needed for this sub are shown above
'
' Programmer = Dick Petschauer; RJPetsch@Aol.com Apr, 1999
' Tested a little. Not gauranteed to be bug free.
Dim SaveFileHeader As BITMAPFILEHEADER
Dim SaveBITMAPINFO_1 As BITMAPINFO_1
Dim SaveBITMAPINFO_4 As BITMAPINFO_4
Dim SaveBITMAPINFO_8 As BITMAPINFO_8
Dim SaveBits() As Byte
Dim BitsPerPixel As Integer
Dim Num32bitWords As Integer
Dim Buffersize As Long
Dim FileNum As Integer
Dim Retval& ' Temporary returns and handles follow
' Set the Scalemode to pixels (*** Note: this also sets the source picturebox to scalemode 3)
pic.ScaleMode = 3 ' Pixels
' Allow for use of color bits to be used instead of the number of colors:
If NumColors = 1 Then NumColors = 2
If NumColors = 4 Then NumColors = 16
If NumColors = 8 Then NumColors = 256
' Check for illegal NumColors. Set to default as monochrome.
If NumColors <> 2 And NumColors <> 16 And NumColors <> 256 Then NumColors = 2
BitsPerPixel = Log(NumColors) / Log(2)
' *** Calculate the buffer for the pixel data
Num32bitWords = (pic.ScaleWidth * BitsPerPixel) \ 32 ' Integer divide
If pic.ScaleWidth Mod 32 > 0 Then Num32bitWords = Num32bitWords + 1 ' End each scan line on '32-bit boundary
Buffersize = Num32bitWords * 4 * pic.ScaleHeight ' 8-bit Bytes; 8 pixels per byte for mono; 2 'for 16 color; 4 for 256 color
' Buffersize can be larger than this; results in larger bitmap file.
ReDim SaveBits(0 To Buffersize - 1)
Debug.Print Buffersize; UBound(SaveBits)
' *** Fill the Bitmap info
If BitsPerPixel = 1 Then
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
SaveBITMAPINFO_1.bmiHeader
End If
If BitsPerPixel = 4 Then
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
SaveBITMAPINFO_4.bmiHeader
End If
If BitsPerPixel = 8 Then
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
SaveBITMAPINFO_8.bmiHeader
End If
' Following Code each on one line (3 occurrances)
If BitsPerPixel = 1 Then Retval& = GetDIBits1(pic.hDC, pic.Image, 0, pic.ScaleHeight, SaveBits(0), SaveBITMAPINFO_1, DIB_RGB_COLORS)
If BitsPerPixel = 4 Then Retval& = GetDIBits4(pic.hDC, pic.Image, 0, pic.ScaleHeight, SaveBits(0), SaveBITMAPINFO_4, DIB_RGB_COLORS)
If BitsPerPixel = 8 Then Retval& = GetDIBits8(pic.hDC, pic.Image, 0, pic.ScaleHeight, SaveBits(0), SaveBITMAPINFO_8, DIB_RGB_COLORS)
If BitsPerPixel = 1 Then BiLen = Len(SaveBITMAPINFO_1)
If BitsPerPixel = 4 Then BiLen = Len(SaveBITMAPINFO_4)
If BitsPerPixel = 8 Then BiLen = Len(SaveBITMAPINFO_8)
' *** Make and fill a Header for the new bitmap
SaveFileHeader.bfType = &H4D42 ' "BM" for Bitmap; first two characters in file
SaveFileHeader.bfSize = Len(SaveFileHeader) + BiLen + Buffersize
SaveFileHeader.bfOffBits = Len(SaveFileHeader) + BiLen
' Here is where you can customize the foreground and background colors for a 2-color bitmap
' For the Foreground color add this line:
' Mid$(SaveBITMAPINFO_1.bmiC
' For the Foreground color add this line:
' Mid$(SaveBITMAPINFO_1.bmiC
' Where ForeBlue, etc are integers from 0 to 255 that represent the respective color strength.
' For white, set all to 255; Black all to 0.
' Defaults: Black foreground, White background.
' *** Save the Bitmap Header and BitmapInfo to disk
' First remove old bitmap file if there
If Dir$(FileName) <> "" Then Kill FileName
FileNum = FreeFile
Open FileName For Binary As FileNum
Put FileNum, , SaveFileHeader
If BitsPerPixel = 1 Then Put FileNum, , SaveBITMAPINFO_1
If BitsPerPixel = 4 Then Put FileNum, , SaveBITMAPINFO_4
If BitsPerPixel = 8 Then Put FileNum, , SaveBITMAPINFO_8
Put FileNum, , SaveBits()
Close FileNum
End Sub
ASKER
MinnEE,
The difference between your version and mine is mainly that yours relies on a PictureBox to be passed... and in order to pass a PictureBox, you have to have a form in your project somewhere to hold that PictureBox. Mine relies on the "StdPicture" OLE variable type... which does NOT require any interface at all... so you could use my version if you had a command-line application which used just standard modules (no interface).
Thanks again,
HATCHET
The difference between your version and mine is mainly that yours relies on a PictureBox to be passed... and in order to pass a PictureBox, you have to have a form in your project somewhere to hold that PictureBox. Mine relies on the "StdPicture" OLE variable type... which does NOT require any interface at all... so you could use my version if you had a command-line application which used just standard modules (no interface).
Thanks again,
HATCHET
If the bitmap is being displayed, wander over to this link:
http://vbaccelerator.com/codelib/gfx/octree.htm
It has a demo project for changing the color depth of bitmaps.