vba中的Timer定时器,支持64位VBA，VB6也通用

全球首发，独创，顶起来，多给评论。

 FORM1.FRM

Dim WithEvents TimerEx1 As TimerEx
Dim WithEvents TimerEx2 As TimerEx

Private Sub Command1_Click()
Set TimerEx1 = New TimerEx
Set TimerEx2 = New TimerEx
TimerEx2.Interval = 1000
TimerEx1.Interval = 2000
TimerEx1.Enabled = True
TimerEx2.Enabled = True
End Sub

Private Sub TimerEx1_Timer()
    Static id As Long
    id = id + 1
    If id > 3 Then id = 0: TimerEx1.Enabled = False
    Msgbox "TimerEx1-" & id
End Sub
Private Sub TimerEx2_Timer()
    Static id As Long
    id = id + 1
    If id > 3 Then id = 0: TimerEx2.Enabled = False
    Msgbox "TimerEx2-" & id
End Sub

TimerEX.CLS

Option Explicit
Dim DoTimes As Long
Dim m_Interval As Long, m_Enabled As Boolean, lngTimerID As Long
Public Event Timer()
Sub TimerProc()
    RaiseEvent Timer
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 lngTimerID <> 0 Then ClassUnloadTimer
    If m_Enabled And m_Interval > 0 Then
        lngTimerID = SetTimer(0, 0, m_Interval, AddressOf TimerExProc)
        TimerExClass.Add Me, lngTimerID & ""
    End If
End Property

Sub ClassUnloadTimer()
    If lngTimerID <> 0 Then
        KillTimer 0, lngTimerID
        TimerExClass.Remove lngTimerID & ""
        lngTimerID = 0
    End If
End Sub
Private Sub Class_Terminate()
    ClassUnloadTimer
End Sub

MODULE1.BAS:

Public Declare PtrSafe Function SetTimer Lib "user32" (ByVal Hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As Long
Public Declare PtrSafe Function KillTimer Lib "user32" (ByVal Hwnd As Long, ByVal nIDEvent As Long) As Long
Public TimerExClass As New Collection
Public Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal Hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, Optional ByVal wType As Long) As Long

Function Msgbox(ByVal Txt As String, Optional ByVal Title As String)
   ' If Title = "" Then Title = App.Title
    MessageBox 0, Txt, Title, 0
End Function

Public Sub TimerExProc(ByVal Hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
    On Error GoTo ERR
    Dim Ex As TimerEx: Set Ex = TimerExClass(idEvent & ""): Ex.TimerProc
    Exit Sub
ERR:      Msgbox "TimerExProc ERR:" & ERR.Description
End Sub