WinAPI Timers can be quite tricky to work with, as anyone who's tried to use them and fallen foul of one of the many pitfalls probably knows. Problems such as screen freezing, crashes, uncontrolled printing to the debug window etc. will be familiar, and so I've tried to make some code to mitigate these issues, by providing a friendlier API to wrap the temperamental bits and hopefully make working with timers a bit easier:
As you can see, editing cells (even using the formula bar), multiple timers, switching windows etc. are all possible within the limitations of WinAPI timers.
I was going to post a section here about the specific problems I've encountered, what causes them (to the best of my knowledge) and how I try to deal with them. However it was getting way too big, so I've moved it to the Github Repo's README, I would recommend checking it out if, after reading the code, you're still not sure why I've gone about it the way I have. Also I'd like to arm any potential reviewers with the subject specific knowledge to break my code efficiently!
Project Layout
The code is intended for use in an add-in (a .xlam file). The main public interface is the TickerAPI predeclared class (used like a static class in other languages); this exposes some friendly helper methods which take in callback functions and other timer parameters and pass them on to the underlying APIs. It also responsible for raising public errors and it stores references to data from the user so that they can be passed to callbacks without risk of the data falling out of scope.
Main Class:TickerAPI
'@Exposed
'@Folder("FirstLevelAPI")
'@PredeclaredID: To ensure it's a singleton in other projects and avoid async nulling
'@ModuleDescription("API for setting up timers to callback functions, wraps Windows Timers")
Option Explicit
Public Enum TimerError
[_ErrBase] = 0
[_Start] = vbObjectError + [_ErrBase]
CreateTimerError
DestroyTimerError
TimerNotFoundError
SynchronousCallError
InvalidTimerFunctionError
GenerateTimerDataError
[_End]
End Enum
Private Const Default_Max_Timer_Count As Long = 100
Private Type tCallback
maxTimerCount As Long
timerManager As ITimerManager
timerDataRepo As New TimerRepository
End Type
Private this As tCallback
Private Sub Class_Initialize()
'Set up defaults
this.maxTimerCount = Default_Max_Timer_Count
Set this.timerManager = New WindowsTimerManager
End Sub
'@Description("Create new timer instance with optional synchronous first call. Returns the ID of the newly created windows timer. Can raise SynchronousCallError if timerFunction fails (and is trapped - unlikely). Raises CreateTimerError if there is an API error")
Public Function StartUnmanagedTimer(ByVal timerFunction As LongPtr, Optional ByVal runImmediately As Boolean = True, Optional ByVal delayMillis As Long = 500, Optional ByVal data As Variant) As LongPtr
Const loggerSourceName As String = "StartUnmanagedTimer"
On Error GoTo generateTimerDataFail
Dim timerInfo As TimerData
Set timerInfo = this.timerDataRepo.Add(UnmanagedCallbackWrapper.Create(timerFunction, data))
On Error GoTo createTimerFail
this.timerManager.StartTimer timerInfo, delayMillis
StartUnmanagedTimer = timerInfo.ID
On Error GoTo scheduleProcFail
If runImmediately Then
If Not this.timerManager.tryTriggerTimer(timerInfo) Then
'queue is too full right now, no point scheduling as it wouldn't be evaluated in time anyway
'could try flushing the queue instead
log WarnLevel, loggerSourceName, "Message queue is too full to post to, so cannot runImmediately"
End If
End If
log InfoLevel, loggerSourceName, printf("UnmanagedTimer with id {0} created", timerInfo.ID)
Exit Function
generateTimerDataFail:
logError "timerSet.Add", Err.Number, Err.Description
raisePublicError GenerateTimerDataError, loggerSourceName
Resume 'for debugging - break above and jump to the error-raising statement
createTimerFail:
logError "createTimer", Err.Number, Err.Description
this.timerDataRepo.Remove timerInfo
raisePublicError CreateTimerError, loggerSourceName
Resume
scheduleProcFail:
logError "scheduleProc", Err.Number, Err.Description
KillTimerByID timerInfo.ID 'NOTE may raise its own public error
raisePublicError SynchronousCallError, loggerSourceName
Resume
End Function
Public Function StartManagedTimer(ByVal timerFunction As ITimerProc, Optional ByVal runImmediately As Boolean = True, Optional ByVal delayMillis As Long = 500, Optional ByVal data As Variant) As LongPtr
Const loggerSourceName As String = "StartManagedTimer"
On Error GoTo generateTimerDataFail
Dim timerInfo As TimerData
Set timerInfo = this.timerDataRepo.Add(ManagedCallbackWrapper.Create(timerFunction, data))
On Error GoTo createTimerFail
this.timerManager.StartTimer timerInfo, delayMillis
StartManagedTimer = timerInfo.ID
On Error GoTo scheduleProcFail
If runImmediately Then
If Not this.timerManager.tryTriggerTimer(timerInfo) Then
'queue is too full right now, no point scheduling as it wouldn't be evaluated in time anyway
'could try flushing the queue instead
log WarnLevel, loggerSourceName, "Message queue is too full to post to, so cannot runImmediately"
End If
End If
log InfoLevel, loggerSourceName, printf("ManagedTimer with id {0} created", timerInfo.ID)
Exit Function
generateTimerDataFail:
logError "timerSet.Add", Err.Number, Err.Description
raisePublicError GenerateTimerDataError, loggerSourceName
Resume 'for debugging - break above and jump to the error-raising statement
createTimerFail:
logError "createTimer", Err.Number, Err.Description
this.timerDataRepo.Remove timerInfo
raisePublicError CreateTimerError, loggerSourceName
Resume
scheduleProcFail:
logError "scheduleProc", Err.Number, Err.Description
KillTimerByID timerInfo.ID 'NOTE may raise an error
raisePublicError SynchronousCallError, loggerSourceName
Resume
End Function
'@Description("API kills windows timer on this handle by ID. Unregistered ID raises TimerNotFoundError, failure to destroy a registered ID raises DestroyTimerError")
Public Sub KillTimerByID(ByVal timerID As LongPtr)
Const loggerSourceName As String = "KillTimerByID"
If this.timerDataRepo.Exists(timerID) Then
On Error GoTo killTimerFail
Dim timerInfo As TimerData
Set timerInfo = this.timerDataRepo.Item(timerID)
this.timerDataRepo.Remove timerInfo
this.timerManager.KillTimer timerInfo
log InfoLevel, loggerSourceName, printf("Timer with id {0} destroyed", timerInfo.ID)
Else
raisePublicError TimerNotFoundError, loggerSourceName
End If
Exit Sub
killTimerFail:
logError "killTimer", Err.Number, Err.Description
raisePublicError DestroyTimerError, loggerSourceName
Resume 'for debugging - break above and jump to the error-raising statement
End Sub
'@Description("Loops through all timers and kills those matching timerFunction - this can be a functionID, a functionObject(ITimerProc) or a functionName")
Public Sub KillTimersByFunction(ByVal timerFunction As Variant)
Const errorSourceName As String = "KillTimersByFunction"
'REVIEW slightly nasty how this method catches and rethrows PUBLIC errors which doubles the cleanup unnecessarily
'Could just remove error guard and raise them itself, but that's risky as there might be unhandled internal errors
On Error GoTo safeThrow
If IsNumeric(timerFunction) Then
If Int(timerFunction) = timerFunction Then 'not a decimal
Me.KillTimersByFunctionID timerFunction
Else
raisePublicError InvalidTimerFunctionError, errorSourceName
End If
ElseIf IsObject(timerFunction) Then
If TypeOf timerFunction Is ITimerProc Then
Me.KillTimersByFunctionID ObjPtr(timerFunction)
Else
raisePublicError InvalidTimerFunctionError, errorSourceName
End If
ElseIf TypeName(timerFunction) = "String" Then
Me.KillTimersByFunctionName timerFunction
Else
raisePublicError InvalidTimerFunctionError, errorSourceName
End If
Exit Sub
safeThrow:
'check if within custom error range; if so then don't rethrow as that would re-terminate and double log the error
If Err.Number > TimerError.[_End] Or Err.Number < TimerError.[_Start] Then
'Unexpected Errors: must throw them to public; no sense condensing as these are all unexpected
raisePublicError Err.Number, "KillTimersByFunction"
Else
'Public Errors: all the cleanup is done, safe to just re-throw
Err.Raise Err.Number
End If
Resume
End Sub
Public Sub KillTimersByFunctionID(ByVal timerFunctionID As LongPtr)
On Error GoTo safeThrow
Dim timer As TimerData
For Each timer In this.timerDataRepo.FilterByFunctionID(timerFunctionID)
KillTimerByID timer.ID
Next timer
Exit Sub
safeThrow:
raisePublicError Err.Number, "KillTimersByFunctionID"
Resume 'for debugging
End Sub
Public Sub KillTimersByFunctionName(ByVal timerFunctionName As String)
On Error GoTo safeThrow
Dim timer As TimerData
For Each timer In this.timerDataRepo.FilterByFunctionName(timerFunctionName)
KillTimerByID timer.ID
Next timer
Exit Sub
safeThrow:
raisePublicError Err.Number, "KillTimersByFunctionName"
Resume 'for debugging
End Sub
Public Sub KillAll()
'NOTE this is called when raising errors so must not generate any itself
On Error Resume Next
this.timerManager.KillAllTimers this.timerDataRepo.ToArray
this.timerDataRepo.Clear
If Err.Number <> 0 Then logError "KillAll", Err.Number, Err.Description
On Error GoTo 0
End Sub
Private Sub raisePublicError(ByVal errorCode As TimerError, Optional ByVal Source As String = "raiseError")
log TraceLevel, "raiseError", "Destroying timers so error can be raised"
Me.KillAll
Select Case errorCode
Case TimerError.CreateTimerError
Err.Description = "Couldn't create Timer"
Case TimerError.DestroyTimerError
Err.Description = "Uh Oh, can't kill the timer :("
Case TimerError.GenerateTimerDataError
Err.Description = "Unable to add/retrieve timer data from the repository"
Case TimerError.InvalidTimerFunctionError
Err.Description = "Invalid timer function supplied; timer functions must be one of:" & vbNewLine _
& " - a TIMERPROC or ITimerProc pointer" & vbNewLine _
& " - an ITimerProc instance" & vbNewLine _
& " - a class name String"
Case TimerError.SynchronousCallError
Err.Description = "Error when running synchronously"
Case TimerError.TimerNotFoundError
Err.Description = "Timer not found"
Case Else
'rethrow error
On Error Resume Next
Err.Raise errorCode 'fake raise to grab text for logging
Dim errDescription As String
errDescription = Err.Description
On Error GoTo 0
Err.Description = errDescription
End Select
logError Source, errorCode, Err.Description 'possibly overkill
Err.Raise errorCode
End Sub
'For testing
Friend Property Get messageWindowHandle()
'only on windows
Dim timerManager As WindowsTimerManager
Set timerManager = this.timerManager
messageWindowHandle = timerManager.messageWindowHandle
End Property
The TickerAPI class holds references to all running timers. It does this by creating an ICallbackWrapper object which holds a reference to the callback function and data passed to the timer. Depending on the kind of callback function (ITimerProc or raw AddressOf TIMERPROC), a Managed/Unmanaged wrapper is created respectively.
Interface Class: ICallbackWrapper
'@Folder("FirstLevelAPI.Utils.Wrappers")
'@Exposed
Option Explicit
Public Property Get FunctionID() As LongPtr
End Property
Public Property Get FunctionName() As String
End Property
Constructor Class: UnmanagedCallbackWrapper
'@Folder("FirstLevelAPI.Utils.Wrappers")
'@PredeclaredID
'@Exposed
Option Explicit
Implements ICallbackWrapper
Private Type tUnmanagedWrapper
callbackFunction As LongPtr
data As Variant
Name As String
End Type
Private this As tUnmanagedWrapper
Private Sub Class_Initialize()
Set this.data = Nothing
this.callbackFunction = 0
'TODO allow custom name
this.Name = WinAPI.GetGUID 'something unique to the function; could be the ptr but that might be reallocated
End Sub
Friend Function Create(ByVal callbackFunction As LongPtr, Optional ByVal data As Variant) As UnmanagedCallbackWrapper
'NOTE only API needs to be able to create these so don't expose
With New UnmanagedCallbackWrapper
.storeData IIf(IsMissing(data), Nothing, data)
.callBack = callbackFunction
Set Create = .Self
End With
End Function
Friend Property Get Self() As UnmanagedCallbackWrapper
Set Self = Me
End Function
Friend Property Let callBack(ByVal value As LongPtr)
this.callbackFunction = value
End Property
Public Sub storeData(ByVal data As Variant)
LetSet this.data, data
End Sub
Public Property Get userData() As Variant
LetSet userData, this.data
End Property
Public Property Get timerID() As LongPtr
timerID = ObjPtr(Me)
End Property
Private Property Get ICallbackWrapper_FunctionID() As LongPtr
ICallbackWrapper_FunctionID = this.callbackFunction
End Property
Private Property Get ICallbackWrapper_FunctionName() As String
ICallbackWrapper_FunctionName = this.Name
End Property
'for testing
Friend Property Get debugName() As String
debugName = this.Name
End Property
Constructor Class: ManagedCallbackWrapper
'@Folder("FirstLevelAPI.Utils.Wrappers")
'@PredeclaredID
Option Explicit
Implements ICallbackWrapper
Private Type tManagedWrapper
callbackFunction As ITimerProc
data As Variant
End Type
Private this As tManagedWrapper
Private Sub Class_Initialize()
Set this.data = Nothing
Set this.callbackFunction = New ITimerProc
End Sub
Public Function Create(ByVal callbackFunction As ITimerProc, Optional ByVal data As Variant) As ManagedCallbackWrapper
'NOTE only API needs to be able to create these so don't expose
With New ManagedCallbackWrapper
.storeData data
Set .callBack = callbackFunction
Set Create = .Self
End With
End Function
Public Property Get Self() As ManagedCallbackWrapper
Set Self = Me
End Function
Public Property Set callBack(ByVal obj As ITimerProc)
Set this.callbackFunction = obj
End Property
Public Property Get callBack() As ITimerProc
Set callBack = this.callbackFunction
End Property
Public Sub storeData(ByVal data As Variant)
LetSet this.data, data
End Sub
Public Property Get userData() As Variant
LetSet userData, this.data
End Property
Public Property Get timerID() As LongPtr
timerID = ObjPtr(Me)
End Property
Private Property Get ICallbackWrapper_FunctionID() As LongPtr
ICallbackWrapper_FunctionID = ObjPtr(this.callbackFunction)
End Property
Private Property Get ICallbackWrapper_FunctionName() As String
ICallbackWrapper_FunctionName = TypeName(this.callbackFunction)
End Property
Public Property Get callbackWrapper() As ICallbackWrapper 'just return the interface; makes it easier to work with
Set callbackWrapper = Me
End Property
These wrapper objects are stored in a TimerRepository, and their ObjPtr()s are used as the unique id for the SetTimer API. This has the side effect of meaning that the TIMERPROC can dereference the pointer back into a (Un)ManagedCallbackWrapper and so the TickerAPI doesn't have to expose them manually. The pointer is to the wrapper's default interface rather than its ICallbackWrapper interface, so the signatures of managed and unmanaged timerProcs are slightly different.
Class: TimerRepository
'@Folder("FirstLevelAPI")
Option Explicit
Private Type repositoryData
TimerData As New Scripting.Dictionary '{id:TimerData}
End Type
Private this As repositoryData
'@DefaultMember
Public Function Item(ByVal timerID As LongPtr) As TimerData
Set Item = this.TimerData.Item(timerID)
End Function
Public Function Add(ByVal callbackWrapper As Object) As TimerData
Dim newData As TimerData
Set newData = TimerData.Create(callbackWrapper)
this.TimerData.Add newData.ID, newData
Set Add = newData
End Function
Public Sub Remove(ByVal timerInfo As TimerData)
this.TimerData.Remove timerInfo.ID
End Sub
Public Sub Clear()
this.TimerData.RemoveAll
End Sub
Public Function ToArray() As Variant
ToArray = this.TimerData.Items
End Function
Public Property Get Exists(ByVal timerID As LongPtr) As Boolean
On Error Resume Next 'if there's a problem then the timerID is as good as unregistered anyway
Exists = this.TimerData.Exists(timerID)
On Error GoTo 0
End Property
Public Function FilterByFunctionID(ByVal funcID As LongPtr) As Collection
Dim matches As New Collection
Dim data As TimerData
For Each data In this.TimerData
If data.callbackWrapperInterface.FunctionID = funcID Then
matches.Add data
End If
Next data
Set FilterByFunctionID = matches
End Function
Public Function FilterByFunctionName(ByVal funcName As String) As Collection
Dim matches As New Collection
Dim data As TimerData
For Each data In this.TimerData
If data.callbackWrapperInterface.FunctionName = funcName Then
matches.Add data
End If
Next data
Set FilterByFunctionName = matches
End Function
The callback wrapper is itself stored within a TimerData object, which provides quick access to the properties required by the ITimerManager; an ITimerManager is responsible for taking the TimerData (which is essentially a generic definition of a timer) and using that info to call WinAPI functions and make a timer with those parameters.
Constructor Class: TimerData
'@Folder("FirstLevelAPI")
'@PredeclaredId: For constructor method
Option Explicit
Private Type tTimerData
callbackWrapper As Object
timerProc As LongPtr
End Type
Private this As tTimerData
Public Function Create(ByVal timerCallbackWrapper As Object) As TimerData
With New TimerData
Set .callbackWrapper = timerCallbackWrapper
If TypeOf timerCallbackWrapper Is ManagedCallbackWrapper Then
.timerProc = VBA.CLngPtr(AddressOf InternalTimerProcs.ManagedTimerCallbackInvoker)
Else
.timerProc = .callbackWrapperInterface.FunctionID
End If
Set Create = .Self
End With
End Function
Friend Property Get Self() As TimerData
Set Self = Me
End Function
Public Property Get callbackWrapperPointer() As LongPtr
callbackWrapperPointer = ObjPtr(this.callbackWrapper)
End Property
Friend Property Get callbackWrapperInterface() As ICallbackWrapper
Set callbackWrapperInterface = this.callbackWrapper
End Property
Public Property Set callbackWrapper(ByVal value As Object)
Set this.callbackWrapper = value
End Property
Public Property Get ID() As LongPtr 'alias
ID = Me.callbackWrapperPointer
End Property
Public Property Get timerProc() As LongPtr
timerProc = this.timerProc
End Property
Friend Property Let timerProc(ByVal value As LongPtr)
this.timerProc = value
End Property
The callback function that is eventually passed to the WinAPI methods is given by the ObjPtr of the ITimerProc associated with a ManagedCallbackWrapper, or it is the default TIMERPROC used by UnManagedCallbackWrappers:
Module: Internal Timer Procs
'@Folder("FirstLevelAPI.Utils")
Option Explicit
Option Private Module
Private Const killTimerOnExecError As Boolean = False 'TODO make these configurable
Private Const terminateOnUnhandledError As Boolean = True
'@Description("TIMERPROC callback for ManagedCallbacks which executes the callback function within error guards")
'@Ignore ParameterNotUsed: callbacks need to have this signature regardless
Public Sub ManagedTimerCallbackInvoker(ByVal windowHandle As LongPtr, ByVal message As WindowsMessage, ByVal timerParams As ManagedCallbackWrapper, ByVal tickCount As Long)
Const loggerSourceName As String = "ManagedTimerCallbackInvoker"
'NOTE could check message and ObjPtr(timerparams) to ensure this is a valid managedTimer caller
On Error Resume Next
timerParams.callBack.Exec timerParams.timerID, timerParams.userData, tickCount
Dim errNum As Long
Dim errDescription As String
errNum = Err.Number 'changing the error policy will wipe these, so cache them
errDescription = Err.Description
'Log any error the callback may have raised, kill it if necessary
On Error GoTo cleanFail 'this procedure cannot raise errors or we'll crash
If errNum <> 0 Then
logError timerParams.callbackWrapper.FunctionName & ".Exec", errNum, errDescription
If killTimerOnExecError Then
On Error GoTo cleanFail
TickerAPI.KillTimerByID timerParams.timerID
End If
End If
cleanExit:
Exit Sub
cleanFail:
logError loggerSourceName, Err.Number, Err.Description
If terminateOnUnhandledError Then Set TickerAPI = Nothing 'kill all timers
Resume cleanExit
End Sub
Interface Class: ITimerManager
'@Folder("FirstLevelAPI")
'@Interface
Option Explicit
Public Enum InternalTimerError
[_ErrBase] = 6 'just in case of clashes, let's offset the errors
[_Start] = vbObjectError + [_ErrBase] 'TimerError.[_End] - 1
CreateMessageWindowError
APIKillTimerError
CastKeyToWrapperError
APIStartTimerError
APIPostMessageError
End Enum
Public Sub KillTimer(ByVal data As TimerData)
End Sub
Public Sub StartTimer(ByVal data As TimerData, ByVal delayMillis As Long)
End Sub
Public Sub UpdateTimer(ByVal data As TimerData, ByVal delayMillis As Long)
End Sub
Public Function tryTriggerTimer(ByVal data As TimerData) As Boolean
End Function
Public Sub KillAllTimers(ByVal dataArray As Variant)
End Sub
The default (and currently only) ITimerManager is the WindowsTimerManager. This is the only class which actually sees WinAPI, and so it handles implementation details. One such implementation detail is creating a ModelessMessageWindow; this provides an hwnd to pass to the SetTimer API (the reason it's done this way is explained in the Github README, essentially a UserForm is easy to destroy and takes down all the timers with it)
Class: WindowsTimerManager
'@Folder("FirstLevelAPI")
Option Explicit
Implements ITimerManager
Private Type windowsTimerManagerData
messageWindow As New ModelessMessageWindow
End Type
Private this As windowsTimerManagerData
Private Sub ITimerManager_KillTimer(ByVal data As TimerData)
'NOTE no need to clear messages as killing the timer invalidates any which have a TIMERPROC argument (which they all do)
On Error GoTo cleanFail
'0 indicates some failure
If WinAPI.KillTimer(this.messageWindow.handle, data.ID) = 0 Then
throwDllError Err.LastDllError, "Call returned zero, probably tried to kill non-existent timer"
End If
cleanExit:
Exit Sub
cleanFail:
logError "WinAPI.KillTimer", Err.Number, Err.Description
raiseInternalError APIKillTimerError, "KillTimer"
Resume cleanExit
End Sub
Private Sub ITimerManager_StartTimer(ByVal data As TimerData, ByVal delayMillis As Long)
Const loggerSourceName As String = "StartTimer"
'Custom handler so we can log precise dll errors and condense error messages + clear up any timer which may have been made
On Error GoTo setTimerFail
Dim newTimerID As LongPtr
newTimerID = WinAPI.SetTimer(this.messageWindow.handle, data.callbackWrapperPointer, delayMillis, data.timerProc)
If newTimerID = 0 Then
throwDllError Err.LastDllError
ElseIf newTimerID <> data.ID Then
Err.Raise 5, Description:="timerID does not have expected value" 'REVIEW is there a better assertion error to raise?
End If
Exit Sub
setTimerFail:
logError "WinAPI.SetTimer", Err.Number, Err.Description
ITimerManager_KillTimer data
raiseInternalError APIStartTimerError, loggerSourceName
Resume 'for debugging - break above and jump to the error-raising statement
End Sub
'TODO never used
Private Sub ITimerManager_UpdateTimer(ByVal data As TimerData, ByVal delayMillis As Long)
'NOTE just an alias for windows timers, maybe not for others
ITimerManager_StartTimer data, delayMillis
End Sub
Private Function ITimerManager_tryTriggerTimer(ByVal data As TimerData) As Boolean
Const loggerSourceName As String = "tryTriggerTimer"
On Error GoTo catchError
'Post fake message to queue to act as an already elapsed timer
If WinAPI.PostMessage(this.messageWindow.handle, WM_TIMER, data.ID, data.timerProc) = 0 Then
throwDllError Err.LastDllError
Else
ITimerManager_tryTriggerTimer = True
End If
cleanExit:
Exit Function
catchError:
If Err.Number = systemErrorCodes.ERROR_NOT_ENOUGH_QUOTA Then
ITimerManager_tryTriggerTimer = False
Resume cleanExit
Else
logError "WinAPI.PostMessage", Err.Number, Err.Description
raiseInternalError APIPostMessageError, loggerSourceName
Resume 'for debugging - break above and jump to the error-raising statement
End If
End Function
Private Sub ITimerManager_KillAllTimers(ByVal dataArray As Variant)
Const loggerSourceName As String = "KillAllTimers"
'NOTE this procedure is called when raising errors so must not raise any itself
On Error Resume Next
log InfoLevel, loggerSourceName, printf("{0} registered timer(s)", UBound(dataArray) - LBound(dataArray)) 'TODO move this elswhere
Set this.messageWindow = Nothing 'terminateMessageWindow - it's autoinstantiated so no tests
If Err.Number <> 0 Then logError loggerSourceName, Err.Number, Err.Description
On Error GoTo 0
End Sub
Private Sub raiseInternalError(ByVal errorCode As InternalTimerError, Optional ByVal Source As String = "raiseInternalError")
Select Case errorCode
Case InternalTimerError.CreateMessageWindowError
Err.Description = "Unable to obtain message window"
Case InternalTimerError.APIKillTimerError
Err.Description = "Error when calling API to destroy timer"
Case InternalTimerError.APIStartTimerError
Err.Description = "Error when calling API to create timer"
Case InternalTimerError.CastKeyToWrapperError
Err.Description = "Failed to cast key object to expected interface"
Case InternalTimerError.APIPostMessageError
Err.Description = "Failed to manually post a message to the queue"
Case Else
'Rethrow error
On Error Resume Next
Err.Raise errorCode 'fake raise to grab text for logging
Dim errDescription As String
errDescription = Err.Description
On Error GoTo 0
Err.Description = errDescription
End Select
'NOTE only log external errors as you can't rely on external loggers
Err.Raise errorCode, Source
End Sub
'For testing
Friend Property Get messageWindowHandle() As LongPtr
messageWindowHandle = this.messageWindow.handle
End Property
UserForm: ModelessMessageWindow (showModal = False)
'@Folder("FirstLevelAPI")
'@ModuleDescription("Lightweight window to provide an hWnd that will be destroyed after a state loss - disconnecting any timers and subclasses which may be attached to it")
'@NoIndent: Conditional compilation doesn't seem to work nicely
Option Explicit
'See https://www.mrexcel.com/forum/excel-questions/967334-much-simpler-alternative-findwindow-api-retrieving-hwnd-userforms.html
#If VBA7 Then
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef outHwnd As LongPtr) As Long
#Else
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByRef outHwnd As Long) As Long
#End If
#If VBA7 Then
Public Property Get handle() As LongPtr
IUnknown_GetWindow Me, handle
End Property
#Else
Public Property Get handle() As Long
IUnknown_GetWindow Me, handle
End Property
#End If
And of course the WinAPI functions
Module: WinAPI
This has a bit of excess (unused) code because I went through many iterations. However it might be helpful to keep for debugging.
'@Folder("WinAPI")
'@IgnoreModule HungarianNotation: For consistency with the docs
'@NoIndent: Indenter doesn't handle PtrSafe very well
Option Explicit
Option Private Module
Public Type tagPOINT
X As Long
Y As Long
End Type
Public Type DWORD 'same size as Long, but intellisense on members is nice
'@Ignore IntegerDataType: https://stackoverflow.com/q/57891281/6609896
LoWord As Integer
'@Ignore IntegerDataType
HiWord As Integer
End Type
Public Type tagMSG
hWnd As LongPtr
message As WindowsMessage
wParam As LongPtr
lParam As LongPtr
time As Long
cursor As tagPOINT
#If Mac Then
lPrivate As Long
#End If
End Type
Public Type timerMessage
windowHandle As LongPtr
messageEnum As WindowsMessage
timerID As LongPtr
timerProc As LongPtr
tickCountTime As Long
cursor As tagPOINT
#If Mac Then
lPrivate As Long
#End If
End Type
Public Type WNDCLASSEX
cbSize As Long
style As Long ' See CS_* constants
lpfnwndproc As LongPtr
' lpfnwndproc As Long
cbClsextra As Long
cbWndExtra As Long
hInstance As LongPtr
hIcon As LongPtr
hCursor As LongPtr
hbrBackground As LongPtr
' hInstance as long
' hIcon as long
' hCursor as long
' hbrBackground as long
lpszMenuName As String
lpszClassName As String
hIconSm As LongPtr
' hIconSm as long
End Type
Public Enum TimerDelay
USER_TIMER_MINIMUM = &HA
USER_TIMER_MAXIMUM = &H7FFFFFFF
End Enum
Public Enum WindowStyle
HWND_MESSAGE = (-3&)
End Enum
Public Enum QueueStatusFlag
QS_TIMER = &H10
QS_ALLINPUT = &H4FF
End Enum
Public Enum PeekMessageFlag
PM_REMOVE = &H1
PM_NOREMOVE = &H0
End Enum
''@Description("Windows Timer Message https://docs.microsoft.com/windows/desktop/winmsg/wm-timer")
Public Enum WindowsMessage
WM_TIMER = &H113
WM_NOTIFY = &H4E 'arbitrary, sounds nice though
End Enum
Public Enum systemErrorCodes
ERROR_NOT_ENOUGH_QUOTA = 1816
End Enum
'Messages
Public Declare Function GetQueueStatus Lib "user32" ( _
ByVal flags As QueueStatusFlag) As DWORD
Public Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" ( _
ByRef lpMsg As tagMSG, _
ByVal hWnd As LongPtr, _
ByVal wMsgFilterMin As WindowsMessage, _
ByVal wMsgFilterMax As WindowsMessage, _
ByVal wRemoveMsg As PeekMessageFlag) As Long
Public Declare Function PeekTimerMessage Lib "user32" Alias "PeekMessageA" ( _
ByRef outMessage As timerMessage, _
ByVal hWnd As LongPtr, _
Optional ByVal wMsgFilterMin As WindowsMessage = WM_TIMER, _
Optional ByVal wMsgFilterMax As WindowsMessage = WM_TIMER, _
Optional ByVal wRemoveMsg As PeekMessageFlag = PM_REMOVE) As Long
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" ( _
ByVal hWnd As LongPtr, _
ByVal msg As WindowsMessage, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As Long
Public Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" ( _
ByVal lpMsg As LongPtr) As LongPtr
Public Declare Function DispatchTimerMessage Lib "user32" Alias "DispatchMessageA" ( _
ByRef message As timerMessage) As LongPtr
'Windows
Public Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" ( _
ByVal dwExStyle As Long, ByVal className As String, ByVal windowName As String, _
ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, _
ByVal hInstance As LongPtr, ByVal lpParam As LongPtr) As LongPtr
Public Declare Function DestroyWindow Lib "user32" ( _
ByVal hWnd As LongPtr) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
'Registering
Public Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" ( _
ByRef pcWndClassEx As WNDCLASSEX) As Long
Public Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" ( _
ByVal lpClassName As String, ByVal hInstance As LongPtr) As Long
Public Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" ( _
ByVal lhwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As Long
Public Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" ( _
ByVal hWnd As LongPtr, _
ByVal uMsg As WindowsMessage, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
Public Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" ( _
ByVal hWnd As LongPtr, _
ByVal pfnSubclass As LongPtr, _
ByVal uIdSubclass As LongPtr, _
Optional ByVal dwRefData As LongPtr) As Long
Public Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" ( _
ByVal hWnd As LongPtr, _
ByVal pfnSubclass As LongPtr, _
ByVal uIdSubclass As LongPtr) As Long
'Timers
Public Declare Function SetTimer Lib "user32" ( _
ByVal hWnd As LongPtr, _
ByVal nIDEvent As LongPtr, _
ByVal uElapse As TimerDelay, _
ByVal lpTimerFunc As LongPtr) As LongPtr
Public Declare Function KillTimer Lib "user32" ( _
ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Public Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As LongPtr, _
ByRef params As UnmanagedCallbackWrapper, _
Optional ByVal message As WindowsMessage = WM_NOTIFY, _
Optional ByVal timerID As Long = 0, _
Optional ByVal unused3 As Long) As LongPtr
Private Type GUID
Data1 As Long
'@Ignore IntegerDataType
Data2 As Integer
'@Ignore IntegerDataType
Data3 As Integer
Data4(7) As Byte
End Type
Private Declare Function CoCreateGuid Lib "OLE32.DLL" (ByRef pGuid As GUID) As Long
'@IgnoreModule EmptyStringLiteral
Public Function GetGUID() As String
'(c) 2000 Gus Molina
Dim udtGUID As GUID
If (CoCreateGuid(udtGUID) = 0) Then
GetGUID = _
String(8 - Len(Hex$(udtGUID.Data1)), "0") & Hex$(udtGUID.Data1) _
& String(4 - Len(Hex$(udtGUID.Data2)), "0") & Hex$(udtGUID.Data2) _
& String(4 - Len(Hex$(udtGUID.Data3)), "0") & Hex$(udtGUID.Data3) _
& IIf((udtGUID.Data4(0) < &H10), "0", "") & Hex$(udtGUID.Data4(0)) _
& IIf((udtGUID.Data4(1) < &H10), "0", "") & Hex$(udtGUID.Data4(1)) _
& IIf((udtGUID.Data4(2) < &H10), "0", "") & Hex$(udtGUID.Data4(2)) _
& IIf((udtGUID.Data4(3) < &H10), "0", "") & Hex$(udtGUID.Data4(3)) _
& IIf((udtGUID.Data4(4) < &H10), "0", "") & Hex$(udtGUID.Data4(4)) _
& IIf((udtGUID.Data4(5) < &H10), "0", "") & Hex$(udtGUID.Data4(5)) _
& IIf((udtGUID.Data4(6) < &H10), "0", "") & Hex$(udtGUID.Data4(6)) _
& IIf((udtGUID.Data4(7) < &H10), "0", "") & Hex$(udtGUID.Data4(7))
End If
End Function
Public Sub PrintMessageQueue(ByVal windowHandle As LongPtr, Optional ByVal filterLow As WindowsMessage = 0, Optional ByVal filterHigh As WindowsMessage = 0)
Dim msg As tagMSG
Dim results As New Dictionary
Do While PeekMessage(msg, windowHandle, filterLow, filterHigh, PM_REMOVE) <> 0
If results.Exists(msg.message) Then
results(msg.message) = results(msg.message) + 1
Else
results(msg.message) = 1
End If
Loop
'put them back?
If results.Count = 0 Then
Debug.Print "No Messages"
Else
Dim key As Variant
For Each key In results.Keys
Debug.Print "#"; key; ":", results(key)
Next key
End If
End Sub
This diagram illustrates how everything fits together (click to enlarge)
Usage
Users don't have to care about any of that though, they just need to decide whether they want to use an Unmanaged or Managed timer:
- Unmanaged timers call TIMERPROCs directly; there is no error guard, so Unmanaged TimerProcs must not raise errors to the caller (the caller is the OS itself so they really musn't, or Excel will crash)
- Managed timers call a default
ManagedTimerCallbackInvokerTimerProc, passing in anITimerProcfunction object. The.Execmethod of theITimerProcis called within VBA OERN guards so Managed timers don't need to worry about raising errors.
Unmanaged timers therefore require a pointer to a function whose signature is a variant on the TIMERPROC signature. Remember the UINT_PTR idEvent is set to the ObjPtr() of the Callback wrapper, meaning it can be dereferenced in place:
Public Sub ExampleUnmanagedTimerProc(ByVal windowHandle As LongPtr, ByVal message As WindowsMessage, ByVal timerParams As UnmanagedCallbackWrapper, ByVal tickCount As Long)
'Do stuff but DON'T RAISE ERRORS!!
End Sub
Called with
Dim timerID As LongPtr
timerID = TickerAPI.StartUnmanagedTimer(AddressOf ExampleUnmanagedTimerProc, delayMillis:=1000, data:="This gets passed to ExampleUnmanagedTimerProc via timerParams.userData")
Managed timers meanwhile require an ITimerProc
Interface Class: ITimerProc
'@Folder("FirstLevelAPI.Utils.Wrappers")
'@Exposed
'@Interface
Option Explicit
Public Sub Exec(ByVal timerID As LongPtr, ByVal userData As Variant, ByVal tickCount As Long)
Err.Raise 5 'not implemented
End Sub
Called with
Dim timerID As LongPtr
timerID = TickerAPI.StartManagedTimer(New HelloWorldProc, delayMillis:=1000, data:=New Collection)
Helpers
A few helper functions are shared in the project:
Module: ProjectUtils
'@Folder("Common")
'@NoIndent: #If isn't handled well
Option Explicit
Option Private Module
Public Const INFINITE_DELAY As Long = &H7FFFFFFF
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef Source As Any, ByVal length As Long)
Private Declare PtrSafe Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (ByRef destination As Any, ByVal length As Long)
#Else
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef destination As Any, ByRef Source As Any, ByVal length As Long)
Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (ByRef destination As Any, ByVal length As Long)
#End If
#If VBA7 Then
Public Function FromPtr(ByVal pData As LongPtr) As Object
#Else
Public Function FromPtr(ByVal pData As Long) As Object
#End If
Dim result As Object
CopyMemory result, pData, LenB(pData)
Set FromPtr = result 'don't copy directly as then reference count won't be managed (I think)
ZeroMemory result, LenB(pData) ' free up memory, equiv: CopyMemory result, 0&, LenB(pData)
End Function
'@Ignore ProcedureCanBeWrittenAsFunction: this should become redundant at some point once RD can understand byRef
Public Sub LetSet(ByRef variable As Variant, ByVal value As Variant)
If IsObject(value) Then
Set variable = value
Else
variable = value
End If
End Sub
Public Sub throwDllError(ByVal ErrorNumber As Long, Optional ByVal onZeroText As String = "DLL error = 0, i.e. no error")
If ErrorNumber = 0 Then
Err.Raise 5, Description:=onZeroText
Else
Err.Raise ErrorNumber, Description:=GetSystemErrorMessageText(ErrorNumber)
End If
End Sub
Public Sub logError(ByVal Source As String, ByVal errNum As Long, ByVal errDescription As String)
If Not LogManager.IsEnabled(ErrorLevel) Then 'check a logger is registered
LogManager.Register DebugLogger.Create("Timing-E", ErrorLevel)
End If
LogManager.log ErrorLevel, Toolbox.Strings.Format("{0} raised an error: #{1} - {2}", Source, errNum, errDescription)
End Sub
Public Sub log(ByVal loggerLevel As LogLevel, ByVal Source As String, ByVal message As String)
If Not LogManager.IsEnabled(TraceLevel) Then 'check a logger is registered
LogManager.Register DebugLogger.Create("Timing", TraceLevel)
End If
LogManager.log loggerLevel, Toolbox.Strings.Format("{0} - {1}", Source, message)
End Sub
And Chip Pearson's error printing module for dll errors
Example
The Timing addin requires a reference to my Toolbox addin for:
- The logger
- Printf / String formatting
The addin code has a password which is 1 to hide it in RD's code explorer.
I've created an example project which references the Timing addin. To use it (until I find a better way of sharing code), you must download the two addins and the example file, open the Timing addin and set a reference to the Toolbox addin, then open the example project and set a reference to the Timing addin.
Here's what's in the example project:
Module: Experiments
Option Explicit
Sub CreateNewTimer()
Dim outputRange As Range
Set outputRange = GUISheet.Range("OutputArea")
TickerAPI.StartManagedTimer New IncrementingTimerProc, delaymillis:=10 ^ (Rnd + 1), Data:=SelectRandomCellFromRange(outputRange)
End Sub
Private Function SelectRandomCellFromRange(ByVal cellRange As Range) As Range
Dim colOffset As Long
colOffset = Application.WorksheetFunction.RandBetween(1, cellRange.Columns.Count)
Dim rowOffset As Long
rowOffset = Application.WorksheetFunction.RandBetween(1, cellRange.Rows.Count)
Set SelectRandomCellFromRange = cellRange.Cells(rowOffset, colOffset)
End Function
Class: IncrementingTimerProc
Option Explicit
Implements Timing.ITimerProc
Private Sub ITimerProc_Exec(ByVal timerID As LongPtr, ByVal userData As Variant, ByVal tickCount As Long)
'Doesn't matter if we raise errors here as this is a managed timer proc, error details are logged
'Can even set breakpoints as long as we don't click `End` during a callback, that will crash Excel
With userData 'assume it's the range we're expecting
If .Value2 >= 10 Then
TickerAPI.KillTimerByID timerID
.Value2 = 0
Else
.Value2 = .Value2 + 1
End If
End With
End Sub
Review Notes:
There are some areas where I'd particularly like feedback if you have any (or don't do any of these, review what you want!)
Errors
I've tried to stick to a pretty rigorous error raising and handling ethos, perhaps I've been a bit overzealous at times. The approach I've taken follows 2 main guidelines:
- Errors raised by a procedure should be of the same degree of abstraction as the procedure itself
- As I understand it, a good procedure tends to do one well defined thing (single responsibility principle?), in a few abstract steps. The caller will know roughly what steps take place in a procedure, even if it doesn't know precisely how they are implemented.
- Therefore I've tried to make procedures which raise a different, unique error for each step. Since each step may raise a number of different errors during its execution, I condense all these implementation level errors into a single step level error, if that makes sense. Some logging takes place with @Mathieu's extensible logging framework to provide a traceback
- Errors can sometimes be interpreted as exceptions (i.e exceptional/special cases which need slightly altered execution pathways, as opposed to bugs/problems that the user needs to know about). However VBA doesn't really have any control structures for handling errors in this way (see trying to implement
try...catchin VBA - it's messy). So errors that I want to interpret as checked Exceptions - expected problems that I know how to deal with - are caught within the procedure that raised them and then reported to the caller as a return value either as aTrue/False, or an error Enum- Encoding exceptions as the return value of functions enables use of control structures like
If...ElseorSelect Case, and (hopefully) avoids GOTOs and spaghetti logic (see the TryParse pattern). - As per the msdn docs on try-parse, unchecked exceptions should still be raised to the caller
- Actual Errors meanwhile don't tend to exist in VBA, but where they do they are either untrappable (Out of stack space) or cause VBA to crash (MoveMemory with bad pointer), so no need to worry about re-raising those.
- Encoding exceptions as the return value of functions enables use of control structures like
As I say, I may have been a bit heavy handed in my application of those principles, and maybe you disagree with the approach entirely, so some reviews on error raising in particular would be really helpful. It all forms part of the API and user experience. Also I've tried to be as succinct as I could in the description of error handling there, but if it's unclear then I can add more - I just thought that even though it's new to me, it's probably not new and pretty obvious to a lot of the people here!
Add-ins
As this is intended for use as an add-in, I've used the Friend modifier as well as Option Private Module. Am I using these appropriately? Option Private Module doesn't seem to stop Public Subs appearing in intellisense for projects which reference the addin.
Unit-Tests
I've written a small number of tests which can be found in the downloadable file - probably too much to review here. However I've been finding it tricky to test this code, partly because everything is asynchronous and that doesn't mesh well with synchronous unit tests. Also I feel like using Friend for exposing internals to unit testing is a bit hacky, so I'm wondering if there's a better way of organising my project to make it more readily test-able.
API
How can I make this more user-friendly? I want people to be able to use this code themselves - is Github + Addin a good way of sharing VBA? Are the TickerAPI public methods useful/ is there anything I should add?
64-Bit & VBA6 compatibility
Ultimately I want to make all the WinAPI declarations 64 bit compatible. Mostly that just means adding PtrSafe, as I always use LongPtr for pointer types. If I want to make this VBA6 safe, then you can see an example of the kind of thing I'd be doing in the Helper module (basically check if LongPtr exists - see here). Does this look correct? I'm not sure if that's the only change though; I don't think .xlam files are compatible with any VBA6 hosts, and maybe a few other issues exist - maybe I won't bother, do you think it's worth it?
Part 2
I'm going to make a second level API which uses events and Metronome objects to provide a source of ticks. That will probably be implemented as a managed timer whose Exec method raises events.
PS; Thanks Rubberduck team, the annotations and code explorer have been life savers!
