www.pudn.com > shrinkVideo.rar > cDIB.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "cDIB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'****************************************************************
'* VB file: cDIB.cls... by Ray Mercer
'* created: 12/1999 by Ray Mercer
'* uploaded: 2/2000
'* modified: 2/25/2000 by Ray Mercer
'* Patrick Pasteels pointed out a bug in my code
'* -fixed: ReDim m_memBitmapInfo(0 To 39) now correctly equals 40 bytes
'*
'*
'* Copyright (C) 1999 - 2000 Ray Mercer. All rights reserved.
'* Latest version can be downloaded from http://www.shrinkwrapvb.com
'****************************************************************
Option Explicit
Private Const BMP_MAGIC_COOKIE As Integer = 19778 'this is equivalent to ascii string "BM"
'//BITMAP DEFINES (from mmsystem.h)
Private Type BITMAPFILEHEADER '14 bytes
bfType As Integer '"magic cookie" - must be "BM"
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
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 RGBQUAD
Red As Byte
Green As Byte
Blue As Byte
Reserved As Byte
End Type
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
'/* constants for the biCompression field */
Private Const BI_RGB As Long = 0&
'#define BI_RLE8 1L
'#define BI_RLE4 2L
'#define BI_BITFIELDS 3L
'for use with AVIFIleInfo
'Private Type AVI_FILE_INFO '108 bytes?
' dwMaxBytesPerSecond As Long
' dwFlags As Long
' dwCaps As Long
' dwStreams As Long
' dwSuggestedBufferSize As Long
' dwWidth As Long
' dwHeight As Long
' dwScale As Long
' dwRate As Long
' dwLength As Long
' dwEditCount As Long
' szFileType As String * 64
'End Type
'Private Declare Function CreateDIBSection_256 Lib "GDI32.DLL" Alias "CreateDIBSection" (ByVal hdc As Long, _
' ByVal pbmi As BITMAPINFO_256, _
' ByVal iUsage As Long, _
' ByRef ppvBits As Long, _
' ByVal hSection As Long, _
' ByVal dwOffset As Long) As Long 'hBitmap
Private Declare Function GetProcessHeap Lib "kernel32.dll" () As Long 'handle
Private Declare Function HeapAlloc Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long 'Pointer to mem
Private Declare Function HeapFree Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long) As Long 'BOOL
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef dest As Any, ByRef src As Any, ByVal dwLen As Long)
Private Const HEAP_ZERO_MEMORY As Long = &H8
Private m_memBits() As Byte
Private m_memBitmapInfo() As Byte
Private m_bih As BITMAPINFOHEADER
Private m_bfh As BITMAPFILEHEADER
Public Function CreateFromFile(ByVal filename As String) As Boolean
Dim hFile As Long
If Not ExistFile(filename) Then
MsgBox "File does not exist:" & vbCrLf & filename, vbCritical, App.title
Exit Function
End If
hFile = FreeFile()
'<====ERROR TRAP ON
On Error Resume Next
Open filename For Binary Access Read As #hFile
If Err Then
If Err.Number = 70 Then
MsgBox "File is locked - cannot access:" & vbCrLf & filename, vbCritical, App.title
Else
MsgBox Err.Description, vbInformation, App.title
End If
Exit Function 'assume file was not opened
End If
On Error GoTo 0
'====>ERROR TRAP OFF
'OK, file is opened - now for the real algorithm...
Get #hFile, , m_bfh 'get the BITMAPFILEHEADER this identifies the bitmap
If m_bfh.bfType <> BMP_MAGIC_COOKIE Then 'this is not a BMP file
MsgBox "File is not a supported bitmap format:" & vbCrLf & filename, vbInformation, App.title
Close #hFile
Exit Function
Else
'now get the info header
Get #hFile, Len(m_bfh) + 1, m_bih 'start at the 15th byte
'now get the bitmap bits
ReDim m_memBits(0 To m_bih.biSizeImage - 1)
Get #hFile, m_bfh.bfOffBits + 1, m_memBits
'and BitmapInfo variable-length UDT
ReDim m_memBitmapInfo(0 To m_bfh.bfOffBits - 14) 'don't need first 14 bytes (fileinfo)
Get #hFile, Len(m_bfh) + 1, m_memBitmapInfo
Close #hFile 'Close file
End If
CreateFromFile = True 'indicate success
' Debug.Print "BitCount: " & vbTab & vbTab & bih.biBitCount
' Debug.Print "ClrImportant: " & vbTab & bih.biClrImportant
' Debug.Print "ClrUsed: " & vbTab & vbTab & bih.biClrUsed
' Debug.Print "Compression: " & vbTab & "&H" & Hex$(bih.biCompression)
' Debug.Print "Height: " & vbTab & vbTab & bih.biHeight
' Debug.Print "Planes: " & vbTab & vbTab & bih.biPlanes 'always 1
' Debug.Print "Size: " & vbTab & vbTab & vbTab & bih.biSize
' Debug.Print "SizeImage: " & vbTab & vbTab & bih.biSizeImage
' Debug.Print "Width: " & vbTab & vbTab & vbTab & bih.biWidth
' Debug.Print "XPelsPerMeter: " & vbTab & bih.biXPelsPerMeter 'usually 0
' Debug.Print "YPelsPerMeter: " & vbTab & bih.biYPelsPerMeter 'usually 0
End Function
Public Function CreateFromPackedDIBPointer(ByRef pDIB As Long) As Boolean
Debug.Assert pDIB <> 0
'Creates a full-color (no palette) DIB from a pointer to a full-color memory DIB
'get the BitmapInfoHeader
Call CopyMemory(ByVal VarPtr(m_bih.biSize), ByVal pDIB, Len(m_bih))
If m_bih.biBitCount < 16 Then
Debug.Print "Error! DIB was less than 16 colors."
Exit Function 'only supports high-color or full-color dibs
End If
'now get the bitmap bits
If m_bih.biSizeImage < 1 Then Exit Function 'return False
ReDim m_memBits(0 To m_bih.biSizeImage - 1)
Call CopyMemory(m_memBits(0), ByVal pDIB + 40, m_bih.biSizeImage)
'and BitmapInfo variable-length UDT
ReDim m_memBitmapInfo(0 To 39) 'don't need first 14 bytes (fileinfo)
Call CopyMemory(m_memBitmapInfo(0), m_bih, Len(m_bih))
'create a file header
With m_bfh
.bfType = BMP_MAGIC_COOKIE
.bfSize = 55 + m_bih.biSizeImage 'size of file as written to disk
.bfReserved1 = 0&
.bfReserved2 = 0&
.bfOffBits = 54 'BitmapInfoHeader + BitmapFileHeader
End With
'and return True
CreateFromPackedDIBPointer = True
End Function
Public Function WriteToFile(ByVal filename As String) As Boolean
Dim hFile As Integer
On Error Resume Next
hFile = FreeFile()
Open filename For Binary As hFile
Put hFile, 1, m_bfh
Put hFile, Len(m_bfh) + 1, m_memBitmapInfo
Put hFile, , m_memBits
Close hFile
WriteToFile = True
End Function
Private Function ExistFile(ByVal sSpec As String) As Boolean
On Error Resume Next
Call fileLen(sSpec)
ExistFile = (Err = 0)
End Function
Public Property Get BitCount() As Long
BitCount = m_bih.biBitCount
End Property
Public Property Get Height() As Long
Height = m_bih.biHeight
End Property
Public Property Get Width() As Long
Width = m_bih.biWidth
End Property
Public Property Get Compression() As Long
Compression = m_bih.biCompression
End Property
Public Property Get SizeInfoHeader() As Long
SizeInfoHeader = m_bih.biSize
End Property
Public Property Get SizeImage() As Long
SizeImage = m_bih.biSizeImage
End Property
Public Property Get Planes() As Long
Planes = m_bih.biPlanes
End Property
Public Property Get ClrImportant() As Long
ClrImportant = m_bih.biClrImportant
End Property
Public Property Get ClrUsed() As Long
ClrUsed = m_bih.biClrUsed
End Property
Public Property Get XPPM() As Long
XPPM = m_bih.biXPelsPerMeter
End Property
Public Property Get YPPM() As Long
YPPM = m_bih.biYPelsPerMeter
End Property
Public Property Get FileType() As Long
FileType = m_bfh.bfType
End Property
Public Property Get SizeFileHeader() As Long
SizeFileHeader = m_bfh.bfSize
End Property
Public Property Get BitOffset() As Long
BitOffset = m_bfh.bfOffBits
End Property
Public Property Get PointerToBits() As Long
PointerToBits = VarPtr(m_memBits(0))
End Property
Public Property Get PointerToBitmapInfo() As Long
PointerToBitmapInfo = VarPtr(m_memBitmapInfo(0))
End Property
Public Property Get SizeBitmapInfo() As Long
SizeBitmapInfo = UBound(m_memBitmapInfo()) + 1
End Property