home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / EGL_ClockC2197882112011.psc / EGL_PictureCubeScreenSaverV3.1 / clsDIB.cls < prev    next >
Text File  |  2010-03-29  |  6KB  |  194 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 = "clsDIB"
  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. Private Const DIB_RGB_COLORS As Long = 0
  17.  
  18. Private Type BITMAPINFOHEADER
  19.     biSize          As Long
  20.     biWidth         As Long
  21.     biHeight        As Long
  22.     biPlanes        As Integer
  23.     biBitCount      As Integer
  24.     biCompression   As Long
  25.     biSizeImage     As Long
  26.     biXPelsPerMeter As Long
  27.     biYPelsPerMeter As Long
  28.     biClrUsed       As Long
  29.     biClrImportant  As Long
  30. End Type
  31.  
  32. Private Type BITMAPINFO
  33.     bmiHeader       As BITMAPINFOHEADER
  34. End Type
  35.  
  36. Private Type SAFEARRAYBOUND
  37.     cElements       As Long
  38.     lLbound         As Long
  39. End Type
  40.  
  41. Private Type SAFEARRAY2D
  42.     cDims           As Integer
  43.     fFeatures       As Integer
  44.     cbElements      As Long
  45.     cLocks          As Long
  46.     pvData          As Long
  47.     Bounds(1)       As SAFEARRAYBOUND
  48. End Type
  49.  
  50. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
  51. Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As 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 Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  56. 'Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
  57. 'Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As Long, ByVal hStretchMode As Long) As Long
  58. Private Declare Function VarPtrArray Lib "MSVBVM60.dll" Alias "VarPtr" (Ptr() As Any) As Long
  59. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  60. Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (Destination As Any, ByVal numBytes As Long)
  61.  
  62. Public hDC       As Long
  63. Public hDIB      As Long
  64. Public Width     As Long
  65. Public Height    As Long
  66. Private m_SizeImage As Long
  67. Private m_hOldDIB   As Long
  68. Private m_lpBits    As Long
  69. Private m_sa        As SAFEARRAY2D
  70.  
  71. Public Sub Create(NewWidth As Long, NewHeight As Long, Data() As Long, Optional Orientation As Boolean = False)
  72.     
  73.     On Error GoTo ErrorCreate
  74.     
  75.     Dim bi  As BITMAPINFO
  76.  
  77.     Width = NewWidth
  78.     Height = NewHeight
  79.     m_SizeImage = NewWidth * NewHeight * 4
  80.     
  81.     With bi.bmiHeader
  82.         .biSize = Len(bi)
  83.         .biWidth = Width
  84.         .biHeight = IIf(Orientation, Height, -Height)
  85.         .biPlanes = 1
  86.         .biBitCount = 32
  87.         .biSizeImage = m_SizeImage
  88.     End With
  89.     
  90.     hDC = CreateCompatibleDC(0)
  91.     If (hDC) Then
  92.         hDIB = CreateDIBSection(hDC, bi, DIB_RGB_COLORS, m_lpBits, 0, 0)
  93.         If (hDIB) Then
  94.             m_hOldDIB = SelectObject(hDC, hDIB)
  95.             With m_sa
  96.                 .cbElements = 4
  97.                 .cDims = 2
  98.                 .Bounds(0).lLbound = 0
  99.                 .Bounds(0).cElements = Height
  100.                 .Bounds(1).lLbound = 0
  101.                 .Bounds(1).cElements = Width
  102.                 .pvData = m_lpBits
  103.             End With
  104.             Call CopyMemory(ByVal VarPtrArray(Data()), VarPtr(m_sa), 4)
  105.         End If
  106.     End If
  107.     Exit Sub
  108.     
  109. ErrorCreate:
  110.     MsgBox "Error: clsDIB > Create"
  111. End Sub
  112.  
  113. Public Sub CreateFromFile(FileName As String, NewWidth As Long, NewHeight As Long, Data() As Long, Optional Orientation As Boolean = False)
  114.     
  115.     On Error GoTo ErrorCreateFromFile
  116.     
  117.     Dim lhDC As Long
  118.     
  119.     Call Create(NewWidth, NewHeight, Data, Orientation)
  120.     If (hDC) Then
  121.         frmCanvas.picLoad.Picture = LoadPicture(FileName)
  122.         lhDC = CreateCompatibleDC(frmCanvas.picLoad.hDC)
  123.         Call SelectObject(lhDC, frmCanvas.picLoad.Picture)
  124.         Call SetStretchBltMode(hDC, vbPaletteModeNone)
  125.         Call StretchBlt(hDC, 0, 0, NewWidth, NewHeight, lhDC, 0, 0, frmCanvas.picLoad.ScaleWidth, frmCanvas.picLoad.ScaleHeight, vbSrcCopy)
  126.         Call DeleteDC(lhDC)
  127.     Else
  128.         GoTo ErrorCreateFromFile
  129.     End If
  130.     Exit Sub
  131.     
  132. ErrorCreateFromFile:
  133.     MsgBox "Error: clsDIB > CreateFromFile"
  134. End Sub
  135.  
  136. Public Function CreateArrayFromPictureBox(Picture As PictureBox, lWidth As Long, lHeight As Long, Data() As Long)
  137.     
  138.     On Error GoTo CreateFromFileError
  139.  
  140.     Dim lhDC As Long
  141.  
  142.     Call Create(lWidth, lHeight, Data)
  143.     lhDC = CreateCompatibleDC(Picture.hDC)
  144.     Call SelectObject(lhDC, Picture.Picture)
  145.     Call SetStretchBltMode(hDC, vbPaletteModeNone)
  146.     Call StretchBlt(hDC, 0, 0, lWidth, lHeight, lhDC, 0, 0, Picture.ScaleWidth, Picture.ScaleHeight, vbSrcCopy)
  147.     DeleteDC lhDC
  148.     Exit Function
  149.     
  150. CreateFromFileError:
  151.     MsgBox "Create From File Error"
  152. End Function
  153.  
  154. Public Sub Clear(Data() As Long)
  155.  
  156.     On Error GoTo ErrorClear
  157.  
  158.     Call ZeroMemory(Data(0, 0), m_SizeImage)
  159.     Exit Sub
  160.  
  161. ErrorClear:
  162.     MsgBox "Error: clsDIB > Clear"
  163. End Sub
  164.  
  165. Public Sub Delete(Data() As Long)
  166.     
  167.     On Error GoTo ErrorDelete
  168.     
  169.     If (hDC) Then
  170.         If (hDIB) Then
  171.             Call CopyMemory(ByVal VarPtrArray(Data()), 0&, 4)
  172.             Call SelectObject(hDC, m_hOldDIB)
  173.             Call DeleteObject(hDIB)
  174.         End If
  175.         Call DeleteDC(hDC)
  176.     End If
  177.     m_hOldDIB = 0
  178.     m_lpBits = 0
  179.     hDIB = 0
  180.     hDC = 0
  181.     Exit Sub
  182.     
  183. ErrorDelete:
  184.     MsgBox "Error: clsDIB > Delete"
  185. End Sub
  186.  
  187. Private Sub Class_Initialize()
  188.  
  189.     hDIB = 0
  190.  
  191. End Sub
  192.  
  193.  
  194.