Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
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 BITMAPINFO2
bmiHeader As BITMAPINFOHEADER
bmiColors(0 To 1) As RGBQUAD
End Type
Private Type BITMAPINFO16
bmiHeader As BITMAPINFOHEADER
bmiColors(0 To 15) As RGBQUAD
End Type
Private Type BITMAPINFO256
bmiHeader As BITMAPINFOHEADER
bmiColors(0 To 255) As RGBQUAD
End Type
Private Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs
Private Declare Function CreateDIBSection2 Lib "gdi32" Alias "CreateDIBSection" _
(ByVal hdc As Long, _
pBitmapInfo As BITMAPINFO2, _
ByVal un As Long, _
lplpVoid As Long, _
ByVal handle As Long, _
ByVal dw As Long) As Long
Private Declare Function CreateDIBSection16 Lib "gdi32" Alias "CreateDIBSection" _
(ByVal hdc As Long, _
pBitmapInfo As BITMAPINFO16, _
ByVal un As Long, _
lplpVoid As Long, _
ByVal handle As Long, _
ByVal dw As Long) As Long
Private Declare Function CreateDIBSection256 Lib "gdi32" Alias "CreateDIBSection" _
(ByVal hdc As Long, _
pBitmapInfo As BITMAPINFO256, _
ByVal un As Long, _
lplpVoid As Long, _
ByVal handle As Long, _
ByVal dw As Long) As Long
Private Const BITMAPTYPE As Integer = &H4D42
Private Type BITMAPFILEHEADER
bfType As Integer '- type ="BM" i.e &H4D42 - 2
bfSize As Long ' - size in bytes of file - 6
bfReserved1 As Integer ' - reserved, must be 0 - 8
bfReserved2 As Integer ' - reserved, must be 0 - 10
bfOffBits As Long ' offset from this structure to the bitmap bits - 14
End Type
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const INVALID_HANDLE_VALUE = -1
Private Const CREATE_ALWAYS = 2
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_BEGIN = 0
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Const GMEM_FIXED = &H0
Private Const GMEM_ZEROINIT = &H40
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments 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 Long, lpBI As BITMAPINFO256, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBitmap Lib "gdi32" (ByVal hdc As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As BITMAPINFO256, ByVal wUsage As Long) As Long
Public Enum EDSSColourDepthConstants
edss2Colour
edss16Colour
edss256Colour
edssTrueColour
End Enum
Public Enum EDSSColourReductionConstants
edssSystemDefault
edssUsePalette
edssGeneratePalette
End Enum
Public Function Save( _
ByVal sFileName As String, _
ByRef cDIB As cDIBSection, _
Optional ByRef cPal As cPalette = Nothing, _
Optional ByVal eOutputColourDepth As EDSSColourDepthConstants = edss256Colour, _
Optional ByVal eColourReductionMethod As EDSSColourReductionConstants = edssSystemDefault _
) As Boolean
Dim tBIH As BITMAPINFOHEADER
If eOutputColourDepth = edssTrueColour Then
' Just directly save the DIBSection as is:
Save = cDIB.SavePicture(sFileName)
Else
' We must create a new DIBSection of the correct colour depth to save.
' Also, we may need to perform a colour depth reduction before saving
' First create the DIBSection
Dim tBI2 As BITMAPINFO2, tBI16 As BITMAPINFO16, tBI256 As cDIBSectionSave.BITMAPINFO256
Dim hDib As Long, lptr As Long, bSuccess As Boolean
Dim lHDC As Long, hBmpOld As Long, lHDCWOrk As Long, i As Long
Dim cDIBWork As cDIBSection
Dim cColReduce As New cColourReduceDIB
Dim bBltIn As Boolean
' Do any colour reduction as required:
Select Case eColourReductionMethod
Case edssSystemDefault
bBltIn = True
Case edssUsePalette
Set cDIBWork = New cDIBSection
cDIBWork.Create cDIB.Width, cDIB.Height
cColReduce.ApplyPalette cDIB, cDIBWork, cPal
Case edssGeneratePalette
Select Case eOutputColourDepth
Case edss256Colour
' Create optimal palette using octree quantisation:
Private Function pbCreate2ColourDIBSection(ByRef hDib As Long, ByRef tBI As BITMAPINFO2, ByRef lptr As Long, ByVal lWidth As Long, ByVal lheight As Long) As Boolean
Private Function pbCreate16ColourDIBSection(ByRef hDib As Long, ByRef tBI As BITMAPINFO16, ByRef lptr As Long, ByVal lWidth As Long, ByVal lheight As Long) As Boolean
Private Function pbCreate256ColourDIBSection(ByRef hDib As Long, ByRef tBI As BITMAPINFO256, ByRef lptr As Long, ByVal lWidth As Long, ByVal lheight As Long, Optional ByRef cP As cPalette = Nothing) As Boolean