vb6写的一个timer定时器类对象

作者：lyserver

这名字好熟悉，感觉在csdn经常看到，应该是个老前辈

以下代码复制到一个 类模块 cTimer.cls

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

Public Event Timer()

Private Sub Class_Initialize()
    m_Interval = 0
    m_lTimerProc = GetClassProcAddr(8)
    'Debug.Print "GetClassProcAddr:" & m_lTimerProc; ""
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
    RaiseEvent Timer
End Sub

用法：和vb自带的定时器一致

Option Explicit

Dim WithEvents t As cTimer


Private Sub Form_Load()
    Set t = New cTimer
    t.Interval = 1000
    t.Enabled = True
End Sub

Private Sub t_Timer()
    Print Now
End Sub

另外，竹笋大师也发了个支持 vba x64 的timer类，有需要的可以去看看

vba中的Timer定时器,支持64位VBA，VB6也通用_vba计时器-CSDN博客
https://blog.csdn.net/xiaoyao961/article/details/131148204

Views: 60