类模块中使用定时器

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

可以使用 Public Event Timer() 和 Private WithEvents mBatchTimer As clsTimer 进行事件触发，需要注意调试的时候及时关闭。

可以通过App.LogMode来判断程序是在调试还是在运行。