home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / vbPainter-2107903302008.psc / Class / cDIB.cls next >
Text File  |  2007-02-20  |  10KB  |  295 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. On Error Resume Next
  112.     Dim hFile As Long
  113.         
  114.     If Not ExistFile(filename) Then
  115.         MsgBox "File does not exist:" & vbCrLf & filename, vbCritical, App.Title
  116.         Exit Function
  117.     End If
  118.         
  119.     hFile = FreeFile()
  120.     
  121.     '<====ERROR TRAP ON
  122.     On Error Resume Next
  123.     Open filename For Binary Access Read As #hFile
  124.     If Err Then
  125.         If Err.Number = 70 Then
  126.             MsgBox "File is locked - cannot access:" & vbCrLf & filename, vbCritical, App.Title
  127.         Else
  128.             MsgBox Err.Description, vbInformation, App.Title
  129.         End If
  130.         Exit Function 'assume file was not opened
  131.     End If
  132.     On Error GoTo 0
  133.     '====>ERROR TRAP OFF
  134.     
  135.     'OK, file is opened - now for the real algorithm...
  136.     Get #hFile, , m_bfh 'get the BITMAPFILEHEADER this identifies the bitmap
  137.  
  138.     If m_bfh.bfType <> BMP_MAGIC_COOKIE Then 'this is not a BMP file
  139.         MsgBox "File is not a supported bitmap format:" & vbCrLf & filename, vbInformation, App.Title
  140.         Close #hFile
  141.         Exit Function
  142.     Else
  143.         'now get the info header
  144.         Get #hFile, Len(m_bfh) + 1, m_bih 'start at the 15th byte
  145.         
  146.         'now get the bitmap bits
  147.         ReDim m_memBits(0 To m_bih.biSizeImage - 1)
  148.         Get #hFile, m_bfh.bfOffBits + 1, m_memBits
  149.         
  150.         'and BitmapInfo variable-length UDT
  151.         ReDim m_memBitmapInfo(0 To m_bfh.bfOffBits - 14) 'don't need first 14 bytes (fileinfo)
  152.         Get #hFile, Len(m_bfh) + 1, m_memBitmapInfo
  153.         
  154.         Close #hFile   'Close file
  155.     End If
  156.     
  157.     CreateFromFile = True 'indicate success
  158.     
  159.     
  160.     
  161. '    Debug.Print "BitCount: " & vbTab & vbTab & bih.biBitCount
  162. '    Debug.Print "ClrImportant: " & vbTab & bih.biClrImportant
  163. '    Debug.Print "ClrUsed: " & vbTab & vbTab & bih.biClrUsed
  164. '    Debug.Print "Compression: " & vbTab & "&H" & Hex$(bih.biCompression)
  165. '    Debug.Print "Height: " & vbTab & vbTab & bih.biHeight
  166. '    Debug.Print "Planes: " & vbTab & vbTab & bih.biPlanes 'always 1
  167. '    Debug.Print "Size: " & vbTab & vbTab & vbTab & bih.biSize
  168. '    Debug.Print "SizeImage: " & vbTab & vbTab & bih.biSizeImage
  169. '    Debug.Print "Width: " & vbTab & vbTab & vbTab & bih.biWidth
  170. '    Debug.Print "XPelsPerMeter: " & vbTab & bih.biXPelsPerMeter 'usually 0
  171. '    Debug.Print "YPelsPerMeter: " & vbTab & bih.biYPelsPerMeter 'usually 0
  172.  
  173. End Function
  174.  
  175. Public Function CreateFromPackedDIBPointer(ByRef pDIB As Long) As Boolean
  176. Debug.Assert pDIB <> 0
  177. 'Creates a full-color (no palette) DIB from a pointer to a full-color memory DIB
  178.  
  179. 'get the BitmapInfoHeader
  180. Call CopyMemory(ByVal VarPtr(m_bih.biSize), ByVal pDIB, Len(m_bih))
  181. If m_bih.biBitCount < 16 Then
  182.     Debug.Print "Error! DIB was less than 16 colors."
  183.     Exit Function 'only supports high-color or full-color dibs
  184. End If
  185.  
  186. 'now get the bitmap bits
  187. If m_bih.biSizeImage < 1 Then Exit Function 'return False
  188. ReDim m_memBits(0 To m_bih.biSizeImage - 1)
  189. Call CopyMemory(m_memBits(0), ByVal pDIB + 40, m_bih.biSizeImage)
  190.  
  191. 'and BitmapInfo variable-length UDT
  192. ReDim m_memBitmapInfo(0 To 39) 'don't need first 14 bytes (fileinfo)
  193. Call CopyMemory(m_memBitmapInfo(0), m_bih, Len(m_bih))
  194.  
  195. 'create a file header
  196. With m_bfh
  197.     .bfType = BMP_MAGIC_COOKIE
  198.     .bfSize = 55 + m_bih.biSizeImage 'size of file as written to disk
  199.     .bfReserved1 = 0&
  200.     .bfReserved2 = 0&
  201.     .bfOffBits = 54 'BitmapInfoHeader + BitmapFileHeader
  202. End With
  203.  
  204. 'and return True
  205. CreateFromPackedDIBPointer = True
  206.  
  207. End Function
  208.  
  209. Public Function WriteToFile(ByVal filename As String) As Boolean
  210. Dim hFile As Integer
  211. On Error Resume Next
  212. hFile = FreeFile()
  213. Open filename For Binary As hFile
  214.     Put hFile, 1, m_bfh
  215.     Put hFile, Len(m_bfh) + 1, m_memBitmapInfo
  216.     Put hFile, , m_memBits
  217. Close hFile
  218. WriteToFile = True
  219. End Function
  220.  
  221. Private Function ExistFile(ByVal sSpec As String) As Boolean
  222.     On Error Resume Next
  223.     Call FileLen(sSpec)
  224.     ExistFile = (Err = 0)
  225. End Function
  226.  
  227. Public Property Get BitCount() As Long
  228.     BitCount = m_bih.biBitCount
  229.  
  230. End Property
  231.  
  232. Public Property Get Height() As Long
  233.     Height = m_bih.biHeight
  234. End Property
  235.  
  236. Public Property Get Width() As Long
  237.     Width = m_bih.biWidth
  238. End Property
  239.  
  240. Public Property Get Compression() As Long
  241.     Compression = m_bih.biCompression
  242. End Property
  243.  
  244. Public Property Get SizeInfoHeader() As Long
  245.     SizeInfoHeader = m_bih.biSize
  246. End Property
  247.  
  248. Public Property Get SizeImage() As Long
  249.     SizeImage = m_bih.biSizeImage
  250. End Property
  251.  
  252. Public Property Get Planes() As Long
  253.     Planes = m_bih.biPlanes
  254. End Property
  255.  
  256. Public Property Get ClrImportant() As Long
  257.     ClrImportant = m_bih.biClrImportant
  258. End Property
  259.  
  260. Public Property Get ClrUsed() As Long
  261.     ClrUsed = m_bih.biClrUsed
  262. End Property
  263.  
  264. Public Property Get XPPM() As Long
  265.     XPPM = m_bih.biXPelsPerMeter
  266. End Property
  267.  
  268. Public Property Get YPPM() As Long
  269.     YPPM = m_bih.biYPelsPerMeter
  270. End Property
  271.  
  272. Public Property Get FileType() As Long
  273.     FileType = m_bfh.bfType
  274. End Property
  275.  
  276. Public Property Get SizeFileHeader() As Long
  277.     SizeFileHeader = m_bfh.bfSize
  278. End Property
  279.  
  280. Public Property Get BitOffset() As Long
  281.     BitOffset = m_bfh.bfOffBits
  282. End Property
  283.  
  284. Public Property Get PointerToBits() As Long
  285.     PointerToBits = VarPtr(m_memBits(0))
  286. End Property
  287.  
  288. Public Property Get PointerToBitmapInfo() As Long
  289.     PointerToBitmapInfo = VarPtr(m_memBitmapInfo(0))
  290. End Property
  291.  
  292. Public Property Get SizeBitmapInfo() As Long
  293.     SizeBitmapInfo = UBound(m_memBitmapInfo()) + 1
  294. End Property
  295.