cmemdc.cls

漂亮的VB版本的界面,界面可以进行扩展并且所需要的代码又非常的少。是一个优秀的原码你可以下载学习之用。

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cMemDC"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ==================================================================================================
' 源程序由 http://vbaccelerator.com 提供(并有DLL库文件)。但由于有一些BUG，导致程序无法正常运行。
'
' 所以，我(天生三排牙，Mail：[e-mail])将它重新整理了一下，并写成了新的DLL库。
'
' 但是，BUG在所难免，所以，请使用的各位小虾、大侠们多提提意见，我也会在有空的时候再修改这个程序的。
'
' 当然，源程序以及DLL库都是免费的，你可以在任何地方使用。但请适当保留原作者信息，以示对原作者的尊重。
'
' 如果你对该程序进行了修改，增加了新的功能，希望能Mail一份给我，让我也分享你的喜悦。谢谢！
' ==================================================================================================

Option Explicit

' ======================================================================================
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
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
Private Type BITMAP '24 bytes
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private m_hDC As Long
Private m_hBmpOld As Long
Private m_hBmp As Long
Private m_lWidth As Long
Private m_lheight As Long
'===================================================
'
'===================================================
Public Sub CreateFromPicture(sPic As IPicture)
    Dim tB As BITMAP
    Dim lhDCC As Long, lhDC As Long
    Dim lhBmpOld As Long
    GetObjectAPI sPic.Handle, Len(tB), tB
    Width = tB.bmWidth
    Height = tB.bmHeight
    lhDCC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
    lhDC = CreateCompatibleDC(lhDCC)
    lhBmpOld = SelectObject(lhDC, sPic.Handle)
    BitBlt hdc, 0, 0, tB.bmWidth, tB.bmHeight, lhDC, 0, 0, vbSrcCopy
    SelectObject lhDC, lhBmpOld
    DeleteDC lhDC
    DeleteDC lhDCC
End Sub
'===================================================
'
'===================================================
Public Property Get hdc() As Long
    hdc = m_hDC
End Property
'===================================================
'
'===================================================
Public Property Let Width(ByVal lW As Long)
    If lW > m_lWidth Then
        pCreate lW, m_lheight
    End If
End Property
'===================================================
'
'===================================================
Public Property Get Width() As Long
    Width = m_lWidth
End Property
'===================================================
'
'===================================================
Public Property Let Height(ByVal lH As Long)
    If lH > m_lheight Then
        pCreate m_lWidth, lH
    End If
End Property
'===================================================
'
'===================================================
Public Property Get Height() As Long
    Height = m_lheight
End Property
'===================================================
'
'===================================================
Private Sub pCreate(ByVal lW As Long, ByVal lH As Long)
Dim lhDC As Long
    pDestroy
    lhDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
    m_hDC = CreateCompatibleDC(lhDC)
    m_hBmp = CreateCompatibleBitmap(lhDC, lW, lH)
    m_hBmpOld = SelectObject(m_hDC, m_hBmp)
    If m_hBmpOld = 0 Then
        pDestroy
    Else
        m_lWidth = lW
        m_lheight = lH
    End If
    DeleteDC lhDC
End Sub
'===================================================
'
'===================================================
Private Sub pDestroy()
    If Not m_hBmpOld = 0 Then
        SelectObject m_hDC, m_hBmpOld
        m_hBmpOld = 0
    End If
    If Not m_hBmp = 0 Then
        DeleteObject m_hBmp
        m_hBmp = 0
    End If
    m_lWidth = 0
    m_lheight = 0
    If Not m_hDC = 0 Then
        DeleteDC m_hDC
        m_hDC = 0
    End If
End Sub
'===================================================
'
'===================================================
Private Sub Class_Terminate()
    pDestroy
End Sub