TimerEx.cls
module1.bas
Code:
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 SubCode:
Option Explicit
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