home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / VIDEO_TO_C2172701122010.psc / cDIB.cls < prev    next >
Text File  |  2009-09-03  |  9KB  |  297 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3. MultiUse = -1 'True
  4. Persistable = 0 'NotPersistable
  5. DataBindingBehavior = 0 'vbNone
  6. DataSourceBehavior  = 0 'vbNone
  7. MTSTransactionMode  = 0 'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cDIB"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. '****************************************************************
  15. '*  VB file:   cDIB.cls... by Ray Mercer
  16. '*  created:   12/1999 by Ray Mercer
  17. '*  uploaded:  2/2000
  18. '*  modified:  2/25/2000 by Ray Mercer
  19. '*             Patrick Pasteels pointed out a bug in my code
  20. '*             -fixed: ReDim m_memBitmapInfo(0 To 39) now correctly equals 40 bytes
  21. '*
  22. '*
  23. '*  Copyright (C) 1999 - 2000 Ray Mercer.  All rights reserved.
  24. '*  Latest version can be downloaded from http://www.shrinkwrapvb.com
  25. '****************************************************************
  26. Option Explicit
  27.  
  28. Private Const BMP_MAGIC_COOKIE As Integer = 19778 'this is equivalent to ascii string "BM"
  29. '//BITMAP DEFINES (from mmsystem.h)
  30. Private Type BITMAPFILEHEADER '14 bytes
  31.     bfType As Integer '"magic cookie" - must be "BM"
  32.     bfSize As Long
  33.     bfReserved1 As Integer
  34.     bfReserved2 As Integer
  35.     bfOffBits As Long
  36. End Type
  37.  
  38. Private Type BITMAPINFOHEADER '40 bytes
  39.     biSize As Long
  40.     biWidth As Long
  41.     biHeight As Long
  42.     biPlanes As Integer
  43.     biBitCount As Integer
  44.     biCompression As Long
  45.     biSizeImage As Long
  46.     biXPelsPerMeter As Long
  47.     biYPelsPerMeter As Long
  48.     biClrUsed As Long
  49.     biClrImportant As Long
  50. End Type
  51.  
  52. Private Type RGBQUAD
  53.     Red As Byte
  54.     Green As Byte
  55.     Blue As Byte
  56.     Reserved As Byte
  57. End Type
  58.  
  59. Private Type Bitmap
  60.     bmType As Long
  61.     bmWidth As Long
  62.     bmHeight As Long
  63.     bmWidthBytes As Long
  64.     bmPlanes As Integer
  65.     bmBitsPixel As Integer
  66.     bmBits As Long
  67. End Type
  68.  
  69. '/* constants for the biCompression field */
  70. Private Const BI_RGB  As Long = 0&
  71. '#define BI_RLE8       1L
  72. '#define BI_RLE4       2L
  73. '#define BI_BITFIELDS  3L
  74. 'for use with AVIFIleInfo
  75.  
  76. 'Private Type AVI_FILE_INFO  '108 bytes?
  77. '    dwMaxBytesPerSecond As Long
  78. '    dwFlags As Long
  79. '    dwCaps As Long
  80. '    dwStreams As Long
  81. '    dwSuggestedBufferSize As Long
  82. '    dwWidth As Long
  83. '    dwHeight As Long
  84. '    dwScale As Long
  85. '    dwRate As Long
  86. '    dwLength As Long
  87. '    dwEditCount As Long
  88. '    szFileType As String * 64
  89. 'End Type
  90.  
  91. 'Private Declare Function CreateDIBSection_256 Lib "GDI32.DLL" Alias "CreateDIBSection" (ByVal hdc As Long, _
  92. '                                                                                ByVal pbmi As BITMAPINFO_256, _
  93. '                                                                                ByVal iUsage As Long, _
  94. '                                                                                ByRef ppvBits As Long, _
  95. '                                                                                ByVal hSection As Long, _
  96. '                                                                                ByVal dwOffset As Long) As Long 'hBitmap
  97. Private Declare Function GetProcessHeap Lib "kernel32.dll" () As Long 'handle
  98. Private Declare Function HeapAlloc Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long 'Pointer to mem
  99. Private Declare Function HeapFree Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long) As Long 'BOOL
  100. Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef dest As Any, ByRef src As Any, ByVal dwLen As Long)
  101.  
  102. Private Const HEAP_ZERO_MEMORY As Long = &H8
  103.  
  104. Private m_memBits() As Byte
  105. Private m_memBitmapInfo() As Byte
  106. Private m_bih As BITMAPINFOHEADER
  107. Private m_bfh As BITMAPFILEHEADER
  108.  
  109.  
  110. Public Function CreateFromFile(ByVal filename As String) As Boolean
  111. Dim hFile As Long
  112.  
  113. If Not ExistFile(filename) Then
  114.     MsgBox "File does not exist:" & vbCrLf & filename, vbCritical, App.title
  115.     Exit Function
  116. End If
  117.  
  118. hFile = FreeFile()
  119.  
  120. '<====ERROR TRAP ON
  121. On Error Resume Next
  122. Open filename For Binary Access Read As #hFile
  123. If Err Then
  124.     If Err.Number = 70 Then
  125.         MsgBox "File is locked - cannot access:" & vbCrLf & filename, vbCritical, App.title
  126.     Else
  127.         MsgBox Err.Description, vbInformation, App.title
  128.     End If
  129.     Exit Function 'assume file was not opened
  130. End If
  131. On Error GoTo 0
  132. '====>ERROR TRAP OFF
  133.  
  134. 'OK, file is opened - now for the real algorithm...
  135. Get #hFile, , m_bfh 'get the BITMAPFILEHEADER this identifies the bitmap
  136.  
  137. If m_bfh.bfType <> BMP_MAGIC_COOKIE Then 'this is not a BMP file
  138.     MsgBox "File is not a supported bitmap format:" & vbCrLf & filename, vbInformation, App.title
  139.     Close #hFile
  140.     Exit Function
  141. Else
  142.     'now get the info header
  143.     Get #hFile, Len(m_bfh) + 1, m_bih 'start at the 15th byte
  144.     
  145.     'now get the bitmap bits
  146.     ReDim m_memBits(0 To m_bih.biSizeImage - 1)
  147.     Get #hFile, m_bfh.bfOffBits + 1, m_memBits
  148.     
  149.     'and BitmapInfo variable-length UDT
  150.     ReDim m_memBitmapInfo(0 To m_bfh.bfOffBits - 14) 'don't need first 14 bytes (fileinfo)
  151.     Get #hFile, Len(m_bfh) + 1, m_memBitmapInfo
  152.     
  153.     Close #hFile 'Close file
  154. End If
  155.  
  156. CreateFromFile = True 'indicate success
  157.  
  158.  
  159.  
  160. '    Debug.Print "BitCount: " & vbTab & vbTab & bih.biBitCount
  161. '    Debug.Print "ClrImportant: " & vbTab & bih.biClrImportant
  162. '    Debug.Print "ClrUsed: " & vbTab & vbTab & bih.biClrUsed
  163. '    Debug.Print "Compression: " & vbTab & "&H" & Hex$(bih.biCompression)
  164. '    Debug.Print "Height: " & vbTab & vbTab & bih.biHeight
  165. '    Debug.Print "Planes: " & vbTab & vbTab & bih.biPlanes 'always 1
  166. '    Debug.Print "Size: " & vbTab & vbTab & vbTab & bih.biSize
  167. '    Debug.Print "SizeImage: " & vbTab & vbTab & bih.biSizeImage
  168. '    Debug.Print "Width: " & vbTab & vbTab & vbTab & bih.biWidth
  169. '    Debug.Print "XPelsPerMeter: " & vbTab & bih.biXPelsPerMeter 'usually 0
  170. '    Debug.Print "YPelsPerMeter: " & vbTab & bih.biYPelsPerMeter 'usually 0
  171.  
  172. End Function
  173.  
  174. Public Function CreateFromPackedDIBPointer(ByRef pDIB As Long) As Boolean
  175.  
  176.  
  177.  
  178. Debug.Assert pDIB <> 0
  179. 'Creates a full-color (no palette) DIB from a pointer to a full-color memory DIB
  180.  
  181. 'get the BitmapInfoHeader
  182. Call CopyMemory(ByVal VarPtr(m_bih.biSize), ByVal pDIB, Len(m_bih))
  183. If m_bih.biBitCount < 16 Then
  184.     Debug.Print "Error! DIB was less than 16 colors."
  185.     Exit Function 'only supports high-color or full-color dibs
  186. End If
  187.  
  188. 'now get the bitmap bits
  189. If m_bih.biSizeImage < 1 Then Exit Function 'return False
  190. ReDim m_memBits(0 To m_bih.biSizeImage - 1)
  191. Call CopyMemory(m_memBits(0), ByVal pDIB + 40, m_bih.biSizeImage)
  192.  
  193. 'and BitmapInfo variable-length UDT
  194. ReDim m_memBitmapInfo(0 To 39) 'don't need first 14 bytes (fileinfo)
  195. Call CopyMemory(m_memBitmapInfo(0), m_bih, Len(m_bih))
  196.  
  197. 'create a file header
  198. With m_bfh
  199.     .bfType = BMP_MAGIC_COOKIE
  200.     .bfSize = 55 + m_bih.biSizeImage 'size of file as written to disk
  201.     .bfReserved1 = 0&
  202.     .bfReserved2 = 0&
  203.     .bfOffBits = 54 'BitmapInfoHeader + BitmapFileHeader
  204. End With
  205.  
  206. 'and return True
  207. CreateFromPackedDIBPointer = True
  208.  
  209. End Function
  210.  
  211. Public Function WriteToFile(ByVal filename As String) As Boolean
  212. Dim hFile As Integer
  213. On Error Resume Next
  214. hFile = FreeFile()
  215. Open filename For Binary As hFile
  216. Put hFile, 1, m_bfh
  217. Put hFile, Len(m_bfh) + 1, m_memBitmapInfo
  218. Put hFile, , m_memBits
  219. Close hFile
  220. WriteToFile = True
  221. End Function
  222.  
  223. Private Function ExistFile(ByVal sSpec As String) As Boolean
  224. On Error Resume Next
  225. Call FileLen(sSpec)
  226. ExistFile = (Err = 0)
  227. End Function
  228.  
  229. Public Property Get BitCount() As Long
  230. BitCount = m_bih.biBitCount
  231.  
  232. End Property
  233.  
  234. Public Property Get Height() As Long
  235. Height = m_bih.biHeight
  236. End Property
  237.  
  238. Public Property Get Width() As Long
  239. Width = m_bih.biWidth
  240. End Property
  241.  
  242. Public Property Get Compression() As Long
  243. Compression = m_bih.biCompression
  244. End Property
  245.  
  246. Public Property Get SizeInfoHeader() As Long
  247. SizeInfoHeader = m_bih.biSize
  248. End Property
  249.  
  250. Public Property Get SizeImage() As Long
  251. SizeImage = m_bih.biSizeImage
  252. End Property
  253.  
  254. Public Property Get Planes() As Long
  255. Planes = m_bih.biPlanes
  256. End Property
  257.  
  258. Public Property Get ClrImportant() As Long
  259. ClrImportant = m_bih.biClrImportant
  260. End Property
  261.  
  262. Public Property Get ClrUsed() As Long
  263. ClrUsed = m_bih.biClrUsed
  264. End Property
  265.  
  266. Public Property Get XPPM() As Long
  267. XPPM = m_bih.biXPelsPerMeter
  268. End Property
  269.  
  270. Public Property Get YPPM() As Long
  271. YPPM = m_bih.biYPelsPerMeter
  272. End Property
  273.  
  274. Public Property Get FileType() As Long
  275. FileType = m_bfh.bfType
  276. End Property
  277.  
  278. Public Property Get SizeFileHeader() As Long
  279. SizeFileHeader = m_bfh.bfSize
  280. End Property
  281.  
  282. Public Property Get BitOffset() As Long
  283. BitOffset = m_bfh.bfOffBits
  284. End Property
  285.  
  286. Public Property Get PointerToBits() As Long
  287. PointerToBits = VarPtr(m_memBits(0))
  288. End Property
  289.  
  290. Public Property Get PointerToBitmapInfo() As Long
  291. PointerToBitmapInfo = VarPtr(m_memBitmapInfo(0))
  292. End Property
  293.  
  294. Public Property Get SizeBitmapInfo() As Long
  295. SizeBitmapInfo = UBound(m_memBitmapInfo()) + 1
  296. End Property
  297.