XTimers.Vbp

XTimerSupport.Bas

Option Explicit

'================================================

' WARNING! DO NOT press the End button while debugging this project! While in Break mode, do NOT make edits that reset the project!

'' This module is dangerous because it uses the SetTimer API and the AddressOf operator to set up a code-only timer. Once such a timer is set up, the system will continue to call the TimerProc function EVEN AFTER YOU RETURN TO DESIGN TIME. Since TimerProc isn't available at design time, the system will cause a PROGRAM FAULT in Visual Basic.

' When debugging this module, you need to make sure that all system timers have been stopped (using KillTimer) before returning to design time. You can do this by calling SCRUB from the Immediate window.

'Call-back timers are inherently dangerous. It's much safer to use Timer controls for most of your development process, and only switch to call-back timers at the very end.

'==================================================

' Amount to increase size of the array maxti when more active timers are needed. (See 'MoreRoom:' below.)

Const MAXTIMERINCREMEMT = 5

Private Type xtimerinfo ' Hungarian xti

xt As XTimer

id As Long

blnReentered As Boolean

End Type

Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerProc As Long) As Long

Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

' maxti is an array of active XTimer objects. The reason for using an array of user-defined types instead of a Collection object is to get early binding when we raise the XTimer object's Tick event.

Private maxti() As XTIMERINFO

'' mintMaxTimers tells us how large the array maxti is at any given time.

Private mintMaxTimers As Integer

' BeginTimer function is called by an XTimer object when the XTimer's Interval property is set to a new non-zero value. The function makes the API calls required to set up a timer. If a timer is successfully created, the function puts a reference to the XTimer object into the array maxti. This reference will be used to call the method that raises the XTimer's Tick event.

Public Function BeginTimer(ByVal xt As XTimer, ByVal Interval As Long)

Dim lngTimerID As Long

Dim intTimerNumber As Integer

lngTimerID = SetTimer(0, 0, Interval, AddressOf TimerProc)

' Success is a non-zero return from SetTimer. If we can't get a timer, raise an error.

If lngTimerID = 0 Then Err.Raise vbObjectError + 31013, , "No timers available"

' The following loop locates the first available slot in the array maxti. If the upper bound is exceeded, an error occurs and the array is made larger. (If you compile this DLL to Native Code, DO NOT turn off Bounds Checking!)

For intTimerNumber = 1 To mintMaxTimers

If maxti(intTimerNumber).id = 0 Then Exit For

Next

'

' If no empty space was found, increase the size of the array.

If intTimerNumber > mintMaxTimers Then

mintMaxTimers = mintMaxTimers + MAXTIMERINCREMEMT

ReDim Preserve maxti(1 To mintMaxTimers)

End If

' Save a reference to use when raising the XTimer object's Tick event.

Set maxti(intTimerNumber).xt = xt

'

' Save the timer id returned by the SetTimer API, and return the value to the XTimer object.

maxti(intTimerNumber).id = lngTimerID

maxti(intTimerNumber).blnReentered = False

BeginTimer = lngTimerID

End Function

' TimerProc is the timer procedure which the system will call whenever one of your timers goes off.

'' IMPORTANT -- Because this procedure must be in a standard module, all of your timer objects must share it. This means the procedure must identify which timer has gone off. This is done by searching the array maxti for the ID of the timer (idEvent).

' If this Sub declaration is wrong, PROGRAM FAULTS will occur! This is one of the dangers of using APIs that require call-back functions.