Public Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal lngSysTime As Long)

Dim intCt As Integer

For intCt = 1 To mintMaxTimers

If maxti(intCt).id = idEvent Then

' Don't raise the event if an earlier instance of this event is still being processed.

If maxti(intCt).BlnReentered Then Exit Sub

' The blnReentered flag blocks further instances of this event until the current instance finishes.

maxti(intCt).blnReentered = True

On Error Resume Next

' Raise the Tick event for the appropriate XTimer object.

maxti(intCt).xt.RaiseTick

If Err.Number <> 0 Then

' If an error occurs, the XTimer has somehow managed to terminate without first letting go of its timer. Clean up the orphaned timer, to prevent GP faults later.

KillTimer 0, idEvent

maxti(intCt).id = 0

' Release the reference to the XTimer object.

Set maxti(intCt).xt = Nothing

End If

' Allow this event to enter TimerProc again.

maxti(intCt).blnReentered = False

Exit Sub

End If

Next

' The following line is a fail-safe, in case an XTimer somehow got freed without the Windows system timer getting killed. Execution can also reach this point because of a known bug with NT 3.51, whereby you may receive one extra timer event AFTER you have executed the KillTimer API.

KillTimer 0, idEvent

End Sub

' EndTimer procedure is called by the XTimer whenever the Enabled property is set to False, and whenever a new timer interval is required.

' There is no way to reset a system timer, so the only way to change the interval is to kill the existing timer and then call BeginTimer to start a new one.

'

Public Sub EndTimer(ByVal xt As xTimer)

Dim lngTimerID As Long

Dim intCt As Integer

' Ask the XTimer for its TimerID, so we can search the array for the correct XTIMERINFO. (You could search for the XTimer reference itself, using the Is operator to compare xt with maxti(intCt).xt, but that wouldn't be as fast.)

lngTimerID = xt.TimerID

' If the timer ID is zero, EndTimer has been called in error.

If lngTimerID = 0 Then Exit Sub

For intCt = 1 To mintMaxTimers

If maxti(intCt).id = lngTimerID Then

' Kill the system timer.

KillTimer 0, lngTimerID

'

' Release the reference to the XTimer object.

Set maxti(intCt).xt = Nothing

'

' Clean up the ID, to free the slot for a new active timer.

maxti(intCt).id = 0

Exit Sub

End If

Next

End Sub

' Scrub procedure is a safety valve for debugging purposes only: If you have to End this project while there are XTimer objects active, call Scrub from the Immediate pane. This will call KillTimer for all of the system timers, so that the development environment can safely return to design mode.

'

Public Sub Scrub()

Dim intCt As Integer

' Kill remaining active timers.

For intCt = 1 To mintMaxTimers

If maxti(intCt).id <> 0 Then KillTimer 0, maxti(intCt).id

Next

End Sub

XTimer.cls

Option Explicit

'' WARNING! DO NOT press the End button while debugging this project! See explanation at the top of the XTimerSupport module (XTimerS.bas).

' Private storage for XTimer properties:

Private mlngTimerID As Long

Private mlngInterval As Long

Private mblnEnabled As Boolean

' The XTimer's only event is Tick. XTimer's Tick event doesn't have any arguments (eliminating arguments speeds up the event slightly), but there's no reason why you couldn't supply arguments if you wanted to.

Event Tick()

' TimerID property is required by the EndTimer procedure, in order to quickly locate the timer in the support module's array of active timers.

'' There's no reason for the client to use this property, so it's declared Friend instead of Public.

'

Friend Property Get TimerID() As Long

TimerID = mlngTimerID

End Property

' Enabled property turns the timer on and off. This is done by killing the system timer, because there's no way to suspend a system timer. If they exist, they're running.

Public Property Get Enabled() As Boolean

Enabled = mblnEnabled

End Property

Public Property Let Enabled(ByVal NewValue As Boolean)

' If there's no change to the state of the property, then exit. This prevents starting a second system timer when one is already running, etcetera.

If NewValue = mblnEnabled Then Exit Property

' Save the new property setting.

mblnEnabled = NewValue

'

' If the Interval is zero, the timer is already stopped. Don't start it.

If mlngInterval = 0 Then Exit Property

'

' Turn timer on or off.

If mblnEnabled Then

Debug.Assert mlngTimerID = 0

mlngTimerID = BeginTimer(Me, mlngInterval)

Else

' The following is necessary, because an XTimer can shut off its system timer two ways: Enabled = False, or Interval = 0.

If mlngTimerID <> 0 Then

Call EndTimer(Me)

mlngTimerID = 0

End If

End If

End Property

' Interval property must do more than just set the timer interval. If the XTimer is enabled, and the Interval is changed from zero to a non-zero value, then a system timer must be started. Likewise, if the Interval is changed to zero, the system timer must be stopped.

'' The Property Let procedure also ends one system timer and starts another whenever the interval changes. This is because there's no way to change the interval of a system timer.'