home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / Convert_Pi2148053292009.psc / cDIB.cls < prev    next >
Text File  |  2008-09-30  |  9KB  |  294 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. Debug.Assert pDIB <> 0
  176. 'Creates a full-color (no palette) DIB from a pointer to a full-color memory DIB
  177.  
  178. 'get the BitmapInfoHeader
  179. Call CopyMemory(ByVal VarPtr(m_bih.biSize), ByVal pDIB, Len(m_bih))
  180. If m_bih.biBitCount < 16 Then
  181.     Debug.Print "Error! DIB was less than 16 colors."
  182.     Exit Function 'only supports high-color or full-color dibs
  183. End If
  184.  
  185. 'now get the bitmap bits
  186. If m_bih.biSizeImage < 1 Then Exit Function 'return False
  187. ReDim m_memBits(0 To m_bih.biSizeImage - 1)
  188. Call CopyMemory(m_memBits(0), ByVal pDIB + 40, m_bih.biSizeImage)
  189.  
  190. 'and BitmapInfo variable-length UDT
  191. ReDim m_memBitmapInfo(0 To 39) 'don't need first 14 bytes (fileinfo)
  192. Call CopyMemory(m_memBitmapInfo(0), m_bih, Len(m_bih))
  193.  
  194. 'create a file header
  195. With m_bfh
  196.     .bfType = BMP_MAGIC_COOKIE
  197.     .bfSize = 55 + m_bih.biSizeImage 'size of file as written to disk
  198.     .bfReserved1 = 0&
  199.     .bfReserved2 = 0&
  200.     .bfOffBits = 54 'BitmapInfoHeader + BitmapFileHeader
  201. End With
  202.  
  203. 'and return True
  204. CreateFromPackedDIBPointer = True
  205.  
  206. End Function
  207.  
  208. Public Function WriteToFile(ByVal FileName As String) As Boolean
  209. Dim hFile As Integer
  210. On Error Resume Next
  211. hFile = FreeFile()
  212. Open FileName For Binary As hFile
  213. Put hFile, 1, m_bfh
  214. Put hFile, Len(m_bfh) + 1, m_memBitmapInfo
  215. Put hFile, , m_memBits
  216. Close hFile
  217. WriteToFile = True
  218. End Function
  219.  
  220. Private Function ExistFile(ByVal sSpec As String) As Boolean
  221. On Error Resume Next
  222. Call FileLen(sSpec)
  223. ExistFile = (Err = 0)
  224. End Function
  225.  
  226. Public Property Get BitCount() As Long
  227. BitCount = m_bih.biBitCount
  228.  
  229. End Property
  230.  
  231. Public Property Get Height() As Long
  232. Height = m_bih.biHeight
  233. End Property
  234.  
  235. Public Property Get Width() As Long
  236. Width = m_bih.biWidth
  237. End Property
  238.  
  239. Public Property Get Compression() As Long
  240. Compression = m_bih.biCompression
  241. End Property
  242.  
  243. Public Property Get SizeInfoHeader() As Long
  244. SizeInfoHeader = m_bih.biSize
  245. End Property
  246.  
  247. Public Property Get SizeImage() As Long
  248. SizeImage = m_bih.biSizeImage
  249. End Property
  250.  
  251. Public Property Get Planes() As Long
  252. Planes = m_bih.biPlanes
  253. End Property
  254.  
  255. Public Property Get ClrImportant() As Long
  256. ClrImportant = m_bih.biClrImportant
  257. End Property
  258.  
  259. Public Property Get ClrUsed() As Long
  260. ClrUsed = m_bih.biClrUsed
  261. End Property
  262.  
  263. Public Property Get XPPM() As Long
  264. XPPM = m_bih.biXPelsPerMeter
  265. End Property
  266.  
  267. Public Property Get YPPM() As Long
  268. YPPM = m_bih.biYPelsPerMeter
  269. End Property
  270.  
  271. Public Property Get FileType() As Long
  272. FileType = m_bfh.bfType
  273. End Property
  274.  
  275. Public Property Get SizeFileHeader() As Long
  276. SizeFileHeader = m_bfh.bfSize
  277. End Property
  278.  
  279. Public Property Get BitOffset() As Long
  280. BitOffset = m_bfh.bfOffBits
  281. End Property
  282.  
  283. Public Property Get PointerToBits() As Long
  284. PointerToBits = VarPtr(m_memBits(0))
  285. End Property
  286.  
  287. Public Property Get PointerToBitmapInfo() As Long
  288. PointerToBitmapInfo = VarPtr(m_memBitmapInfo(0))
  289. End Property
  290.  
  291. Public Property Get SizeBitmapInfo() As Long
  292. SizeBitmapInfo = UBound(m_memBitmapInfo()) + 1
  293. End Property
  294.