home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 5_2007-2008.ISO / data / Zips / Outlook_2K2097081112008.psc / cMemDC.cls < prev    next >
Text File  |  2008-01-12  |  4KB  |  133 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 = "cMemDC"
  10. Attribute VB_GlobalNameSpace = True
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. ' ======================================================================================
  17. ' Name:     cMemDC.cls
  18. ' Author:   Steve McMahon (steve@vbaccelerator.com)
  19. ' Date:     20 October 1999
  20. '
  21. ' Requires: -
  22. '
  23. ' Copyright ⌐ 1999 Steve McMahon for vbAccelerator
  24. ' --------------------------------------------------------------------------------------
  25. ' Visit vbAccelerator - advanced free source code for VB programmers
  26. '    http://vbaccelerator.com
  27. ' --------------------------------------------------------------------------------------
  28. '
  29. ' Memory DC for flicker free drawing.
  30. '
  31. ' FREE SOURCE CODE - ENJOY!
  32. ' Do not sell this code.  Credit vbAccelerator.
  33. ' ======================================================================================
  34. Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
  35. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  36. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  37. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  38. Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
  39. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  40. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  41. 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
  42. Private Type BITMAP '24 bytes
  43.    bmType As Long
  44.    bmWidth As Long
  45.    bmHeight As Long
  46.    bmWidthBytes As Long
  47.    bmPlanes As Integer
  48.    bmBitsPixel As Integer
  49.    bmBits As Long
  50. End Type
  51. Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  52.  
  53. Private m_hDC As Long
  54. Private m_hBmpOld As Long
  55. Private m_hBmp As Long
  56. Private m_lWidth As Long
  57. Private m_lheight As Long
  58.  
  59. Public Sub CreateFromPicture(sPic As IPicture)
  60. Dim tB As BITMAP
  61. Dim lhDCC As Long, lhDC As Long
  62. Dim lhBmpOld As Long
  63.    GetObjectAPI sPic.handle, Len(tB), tB
  64.    Width = tB.bmWidth
  65.    Height = tB.bmHeight
  66.    lhDCC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
  67.    lhDC = CreateCompatibleDC(lhDCC)
  68.    lhBmpOld = SelectObject(lhDC, sPic.handle)
  69.    BitBlt hdc, 0, 0, tB.bmWidth, tB.bmHeight, lhDC, 0, 0, vbSrcCopy
  70.    SelectObject lhDC, lhBmpOld
  71.    DeleteDC lhDC
  72.    DeleteDC lhDCC
  73. End Sub
  74.  
  75. Public Property Get hdc() As Long
  76.    hdc = m_hDC
  77. End Property
  78. Public Property Let Width(ByVal lW As Long)
  79.    If lW > m_lWidth Then
  80.       pCreate lW, m_lheight
  81.    End If
  82. End Property
  83. Public Property Get Width() As Long
  84.    Width = m_lWidth
  85. End Property
  86. Public Property Let Height(ByVal lH As Long)
  87.    If lH > m_lheight Then
  88.       pCreate m_lWidth, lH
  89.    End If
  90. End Property
  91. Public Property Get Height() As Long
  92.    Height = m_lheight
  93. End Property
  94. Public Sub Create(lWidth As Long, lHeight As Long)
  95.   pCreate lWidth, lHeight
  96. End Sub
  97. Private Sub pCreate(ByVal lW As Long, ByVal lH As Long)
  98. Dim lhDC As Long
  99.    pDestroy
  100.    lhDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
  101.    m_hDC = CreateCompatibleDC(lhDC)
  102.    m_hBmp = CreateCompatibleBitmap(lhDC, lW, lH)
  103.    m_hBmpOld = SelectObject(m_hDC, m_hBmp)
  104.    If m_hBmpOld = 0 Then
  105.       pDestroy
  106.    Else
  107.       m_lWidth = lW
  108.       m_lheight = lH
  109.    End If
  110.    DeleteDC lhDC
  111. End Sub
  112. Private Sub pDestroy()
  113.    If Not m_hBmpOld = 0 Then
  114.       SelectObject m_hDC, m_hBmpOld
  115.       m_hBmpOld = 0
  116.    End If
  117.    If Not m_hBmp = 0 Then
  118.       DeleteObject m_hBmp
  119.       m_hBmp = 0
  120.    End If
  121.    m_lWidth = 0
  122.    m_lheight = 0
  123.    If Not m_hDC = 0 Then
  124.       DeleteDC m_hDC
  125.       m_hDC = 0
  126.    End If
  127. End Sub
  128.  
  129. Private Sub Class_Terminate()
  130.    pDestroy
  131. End Sub
  132.  
  133.