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_BITFIELDS,BI_JPEG,BI_PNG)
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.biCompression
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.Handle, Len(PicInfo), PicInfo) = 0 Then Exit Function
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_Screen)
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.Handle, IMAGE_BITMAP, PicWidth, PicHeight, LR_MONOCHROME)
Else
hBMP_Pic = CopyImage(Picture_BMP.Handle, IMAGE_BITMAP, PicWidth, PicHeight, 0)
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 = 0 ' Not Used
.bmiHeader.biYPelsPerMeter = 0 ' Not Used
.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 = 0 ' Not Used
.bmiHeader.biYPelsPerMeter = 0 ' Not Used
.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 = 0 ' Not Used
.bmiHeader.biYPelsPerMeter = 0 ' Not Used
.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
