在VB的類子產品中使用定時器

    長久以來，由于不能直接獲得VB類成員函數指針，因為無法在VB的類子產品中直接使用定時器控件或定時器API，基于俺編寫的獲得類成員函數指針的函數，俺編寫了這個帶定時器功能的類，希望給朋友們一些啟發。

    一、建立一個類，類名稱為clsTimer，類代碼如下：

Option Explicit

'* ******************************************** *

'* 子產品名稱：clsTimer.cls

'* 功能：在VB類子產品中使用計時器

'* 作者：lyserver

'* ******************************************** *

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, _

Source As Any, ByVal Length As Long)

Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, _

ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long

Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Dim m_idTimer As Long

Dim m_Enabled As Boolean

Dim m_Interval As Long

Dim m_lTimerProc As Long

Private Sub Class_Initialize()

m_Interval = 0

m_lTimerProc = GetClassProcAddr(8)

End Sub

Private Sub Class_Terminate()

If m_idTimer <> 0 Then KillTimer 0, m_idTimer

End Sub

Public Property Get Interval() As Long

Interval = m_Interval

End Property

Public Property Let Interval(ByVal New_Value As Long)

If New_Value >= 0 Then m_Interval = New_Value

End Property

Public Property Get Enabled() As Boolean

Enabled = m_Enabled

End Property

Public Property Let Enabled(ByVal New_Value As Boolean)

m_Enabled = New_Value

If m_idTimer <> 0 Then KillTimer 0, m_idTimer

If New_Value And m_Interval > 0 Then

m_idTimer = SetTimer(0, 0, m_Interval, m_lTimerProc)

End If

End Property

Private Function GetClassProcAddr(ByVal Index As Long, Optional ParamCount As Long = 4, Optional HasReturnValue As Boolean) As Long

Static lReturn As Long, pReturn As Long

Static AsmCode(50) As Byte

Dim i As Long, pThis As Long, pVtbl As Long, pFunc As Long

pThis = ObjPtr(Me)

CopyMemory pVtbl, ByVal pThis, 4

CopyMemory pFunc, ByVal pVtbl + (6 + Index) * 4, 4

pReturn = VarPtr(lReturn)

For i = 0 To UBound(AsmCode)

AsmCode(i) = &H90

Next

AsmCode(0) = &H55

AsmCode(1) = &H8B: AsmCode(2) = &HEC

AsmCode(3) = &H53

AsmCode(4) = &H56

AsmCode(5) = &H57

If HasReturnValue Then

AsmCode(6) = &HB8

CopyMemory AsmCode(7), pReturn, 4

AsmCode(11) = &H50

End If

For i = 0 To ParamCount - 1

AsmCode(12 + i * 3) = &HFF

AsmCode(13 + i * 3) = &H75

AsmCode(14 + i * 3) = (ParamCount - i) * 4 + 4

Next

i = i * 3 + 12

AsmCode(i) = &HB9

CopyMemory AsmCode(i + 1), pThis, 4

AsmCode(i + 5) = &H51

AsmCode(i + 6) = &HE8

CopyMemory AsmCode(i + 7), pFunc - VarPtr(AsmCode(i + 6)) - 5, 4

If HasReturnValue Then

AsmCode(i + 11) = &HB8

CopyMemory AsmCode(i + 12), pReturn, 4

AsmCode(i + 16) = &H8B

AsmCode(i + 17) = &H0

End If

AsmCode(i + 18) = &H5F

AsmCode(i + 19) = &H5E

AsmCode(i + 20) = &H5B

AsmCode(i + 21) = &H8B: AsmCode(i + 22) = &HE5

AsmCode(i + 23) = &H5D

AsmCode(i + 24) = &HC3

GetClassProcAddr = VarPtr(AsmCode(0))

End Function

Private Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)

Debug.Print "類模闆中的計時器：", uMsg, idEvent, dwTime

End Sub

    二、測試代碼如下：

Dim m_tm As clsTimer

Private Sub Form_Load()

Set m_tm = New clsTimer

End Sub

Private Sub Form_Unload(Cancel As Integer)

Set m_tm = Nothing

End Sub

Private Sub Command1_Click()

m_tm.Interval = 1000

m_tm.Enabled = True

End Sub

Private Sub Command2_Click()

m_tm.Enabled = False

End Sub