ViDock/SurfaceDC.cls at master · lee-soft/ViDock · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
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 = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
' ======================================================================================
' Name:     cMemDC.cls
' Author:   Steve McMahon (steve@vbaccelerator.com)
' Date:     20 October 1999
'
' Requires: -
'
' Copyright © 1999 Steve McMahon for vbAccelerator
' --------------------------------------------------------------------------------------
' Visit vbAccelerator - advanced free source code for VB programmers
'    http://vbaccelerator.com
' --------------------------------------------------------------------------------------
'
' Memory DC for flicker free drawing.
'
' FREE SOURCE CODE - ENJOY!
' Do not sell this code.  Credit vbAccelerator.
' ======================================================================================
'
' Declerations removed since they exist in the TLB

Option Explicit

Private m_hDC     As Long

Private m_hBmp    As Long

Private m_hBmpOld As Long

Private m_lWidth  As Long

Private m_lHeight As Long

Public Property Get Width() As Long
    Width = m_lWidth
End Property

Public Property Let Width(ByVal Value As Long)

    If (Value > m_lWidth) Then
        m_lWidth = Value
        pCreate m_lWidth, m_lHeight
        SetBkMode m_hDC, 1
    End If

End Property

Public Property Get Height() As Long
    Height = m_lHeight
End Property

Public Property Let Height(ByVal Value As Long)

    If (Value > m_lHeight) Then
        m_lHeight = Value
        pCreate m_lWidth, m_lHeight
        SetBkMode m_hDC, 1
    End If

End Property

Public Property Get hdc() As Long
    hdc = m_hDC
End Property

Public Function CreateFromBitmap(strFile As String)
    'Creates a bitmap hdc
    'Returns the bitmap hdc
    pDestroy

    Dim lngBitMapDC As Long

    Dim vbPic       As IPictureDisp

    lngBitMapDC = CreateCompatibleDC(0)
    Set vbPic = LoadPicture(strFile)

    SelectObject lngBitMapDC, vbPic

    m_lHeight = vbPic.Height / 26.45454545455
    m_lWidth = vbPic.Width / 26.45454545455

    m_hDC = lngBitMapDC

End Function

Private Sub pCreate(ByVal Width As Long, ByVal Height As Long)

    Dim lhDCC    As Long

    Dim initData As DEVMODE

    pDestroy
    lhDCC = CreateDC("DISPLAY", "", "", initData)

    If Not (lhDCC = 0) Then
        m_hDC = CreateCompatibleDC(lhDCC)

        If Not (m_hDC = 0) Then
            m_hBmp = CreateCompatibleBitmap(lhDCC, Width, Height)

            If Not (m_hBmp = 0) Then
                m_hBmpOld = SelectObject(m_hDC, m_hBmp)

                If Not (m_hBmpOld = 0) Then
                    m_lWidth = Width
                    m_lHeight = Height
                    DeleteDC lhDCC

                    Exit Sub

                End If
            End If
        End If

        DeleteDC lhDCC
        pDestroy
    End If

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

    If Not m_hDC = 0 Then
        DeleteDC m_hDC
        m_hDC = 0
    End If

    m_lWidth = 0
    m_lHeight = 0
End Sub

Private Sub Class_Terminate()
    pDestroy
End Sub