home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / image_conv1744395122004.psc / imageconverter / Class / cDIBSectionmod.cls next >
Text File  |  2004-05-12  |  6KB  |  168 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 = "cDIBSection"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15. ' ==================================================================================
  16. ' Requires:    mIJLmod.cls
  17. '              ijl15.dll (Intel)
  18. ' ==================================================================================
  19.  
  20. Private Type RGBQUAD
  21.     rgbBlue As Byte
  22.     rgbGreen As Byte
  23.     rgbRed As Byte
  24.     rgbReserved As Byte
  25. End Type
  26. Private Type BITMAPINFOHEADER '40 bytes
  27.     biSize As Long
  28.     biWidth As Long
  29.     biHeight As Long
  30.     biPlanes As Integer
  31.     biBitCount As Integer
  32.     biCompression As Long
  33.     biSizeImage As Long
  34.     biXPelsPerMeter As Long
  35.     biYPelsPerMeter As Long
  36.     biClrUsed As Long
  37.     biClrImportant As Long
  38. End Type
  39. Private Type BITMAPINFO
  40.     bmiHeader As BITMAPINFOHEADER
  41.     bmiColors As RGBQUAD
  42. End Type
  43. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
  44. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  45.  
  46. Private Declare Function GetDesktopWindow Lib "user32" () As Long
  47. Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDc As Long, pBitmapInfo As BITMAPINFO, ByVal un As _
  48.     Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
  49. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth _
  50.     As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As _
  51.     Long) As Long
  52. Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
  53. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  54. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
  55. Private Const BI_RGB = 0&
  56. Private Const BI_RLE4 = 2&
  57. Private Const BI_RLE8 = 1&
  58. Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
  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. Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, _
  69.     lpObject As Any) As Long
  70.  
  71. ' Handle to the current DIBSection:
  72. Private m_hDIb As Long
  73. ' Handle to the old bitmap in the DC, for clear up:
  74. Private m_hBmpOld As Long
  75. ' Handle to the Device context holding the DIBSection:
  76. Private m_hDC As Long
  77. ' Address of memory pointing to the DIBSection's bits:
  78. Private m_lPtr As Long
  79. ' Type containing the Bitmap information:
  80. Private m_tBI As BITMAPINFO
  81.  
  82. Public Property Get BytesPerScanLine() As Long
  83.     ' Scans must align on dword boundaries:
  84.     BytesPerScanLine = (m_tBI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
  85. End Property
  86.  
  87. Public Property Get Width() As Long
  88.     Width = m_tBI.bmiHeader.biWidth
  89. End Property
  90.  
  91. Public Property Get Height() As Long
  92.     Height = m_tBI.bmiHeader.biHeight
  93. End Property
  94.  
  95. Public Sub LoadPictureBlt( ByVal lhDC As Long, Optional ByVal lSrcLeft As Long = 0, Optional ByVal lSrcTop _
  96.         As Long = 0, Optional ByVal lSrcWidth As Long = -1, Optional ByVal lSrcHeight As Long = -1, Optional ByVal _
  97.         eRop As RasterOpConstants = vbSrcCopy )
  98.     If lSrcWidth < 0 Then lSrcWidth = m_tBI.bmiHeader.biWidth
  99.     If lSrcHeight < 0 Then lSrcHeight = m_tBI.bmiHeader.biHeight
  100.     BitBlt m_hDC, 0, 0, lSrcWidth, lSrcHeight, lhDC, lSrcLeft, lSrcTop, eRop
  101. End Sub
  102.  
  103. Public Property Get DIBSectionBitsPtr() As Long
  104.     DIBSectionBitsPtr = m_lPtr
  105. End Property
  106.  
  107. Public Sub ClearUp()
  108.     If (m_hDC <> 0) Then
  109.         If (m_hDIb <> 0) Then
  110.             SelectObject m_hDC, m_hBmpOld
  111.             DeleteObject m_hDIb
  112.         End If
  113.         DeleteObject m_hDC
  114.     End If
  115.     m_hDC = 0: m_hDIb = 0: m_hBmpOld = 0: m_lPtr = 0
  116. End Sub
  117.  
  118. Public Function CreateFromPicture( ByRef picThis As StdPicture )
  119.   Dim lhDC As Long
  120.   Dim lhDCDesktop As Long
  121.   Dim lhBmpOld As Long
  122.   Dim tBMP As BITMAP
  123.     
  124.     GetObjectAPI picThis.handle, Len(tBMP), tBMP
  125.     If (Create(tBMP.bmWidth, tBMP.bmHeight)) Then
  126.         lhDCDesktop = GetDC(GetDesktopWindow())
  127.         If (lhDCDesktop <> 0) Then
  128.             lhDC = CreateCompatibleDC(lhDCDesktop)
  129.             DeleteDC lhDCDesktop
  130.             If (lhDC <> 0) Then
  131.                 lhBmpOld = SelectObject(lhDC, picThis.handle)
  132.                 LoadPictureBlt lhDC
  133.                 SelectObject lhDC, lhBmpOld
  134.                 DeleteObject lhDC
  135.             End If
  136.         End If
  137.     End If
  138. End Function
  139.  
  140. Public Function CreateDIB( ByVal lhDC As Long, ByVal lWidth As Long, ByVal lHeight As Long, ByRef hDib As Long _
  141.         ) As Boolean
  142.     With m_tBI.bmiHeader
  143.         .biSize = Len(m_tBI.bmiHeader)
  144.         .biWidth = lWidth
  145.         .biHeight = lHeight
  146.         .biPlanes = 1
  147.         .biBitCount = 24
  148.         .biCompression = BI_RGB
  149.         .biSizeImage = BytesPerScanLine * .biHeight
  150.     End With
  151.     hDib = CreateDIBSection( lhDC, m_tBI, DIB_RGB_COLORS, m_lPtr, 0, 0)
  152.     CreateDIB = (hDib <> 0)
  153. End Function
  154.  
  155. Public Function Create( ByVal lWidth As Long, ByVal lHeight As Long ) As Boolean
  156.     ClearUp
  157.     m_hDC = CreateCompatibleDC(0)
  158.     If (m_hDC <> 0) Then
  159.         If (CreateDIB(m_hDC, lWidth, lHeight, m_hDIb)) Then
  160.             m_hBmpOld = SelectObject(m_hDC, m_hDIb)
  161.             Create = True
  162.         Else
  163.             DeleteObject m_hDC
  164.             m_hDC = 0
  165.         End If
  166.     End If
  167. End Function
  168.