12
\$\begingroup\$

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:

Example program

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) Project layout diagram


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 ManagedTimerCallbackInvoker TimerProc, passing in an ITimerProc function object. The .Exec method of the ITimerProc is 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:

  1. 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
  2. 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...catch in 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 a True/False, or an error Enum
    • Encoding exceptions as the return value of functions enables use of control structures like If...Else or Select 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.

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!

\$\endgroup\$
5
+50
\$\begingroup\$

First I'd like to say that this is impressive work, overall pretty squeaky clean... despite the adjustments needed to make it build on x64 :)

One enhancement I can see in terms of readability, would be to use PascalCase rather than camelCase for member names: inconsistent casing is distracting, because parameters and locals are usually camelCase, so a camel-cased procedure name tends to register as such on first read.

Start[Unm|M]anagedTimer is doing too many things, as hinted by the 3 error-handling subroutines:

On Error GoTo generateTimerDataFail
' do stuff...

On Error GoTo createTimerFail
' do stuff...

On Error GoTo scheduleProcFail
' do more stuff...

The first two really feel like they belong in their own private scope/function; this would help remove some of the duplication between the two functions.

This is a bit dangerous:

    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

A Resume statement jumps right back to the statement that caused the problem in the first place: if that statement throws the same error again, we're very likely stuck in an infinite loop. Breakpoints aren't necessarily going to be there next time. An unreachable Stop statement that can only run if the "prod path" Resume statement is commented-out to make the debugger hit a programmatic breakpoint that effectively halts the "debug path" infinite loop:

    log InfoLevel, loggerSourceName, printf("ManagedTimer with id {0} created", timerInfo.ID)
CleanExit:
    Exit Function

generateTimerDataFail:
    logError "timerSet.Add", Err.Number, Err.Description
    raisePublicError GenerateTimerDataError, loggerSourceName
    Resume CleanExit ' DEBUG: comment-out this statement
    Stop
    Resume

Rubberduck will warn about the Stop statement, but only until (soon) it's able to determine that the execution path jumps out at Resume and the Stop statement is actually unreachable.


TimerData.ID aliasing TimerData.CallbackWrapperPointer makes the API needlessly confusing: in general the fewer different ways there are to do something or get a value, the better. The two members being on the same default interface (TimerData) feels like one of the two is redundant.


Watch out for As New declarations; often, they aren't necessary and would be better off initialized in the Class_Initialize handler.

Some enum members are hard to explain, too:

Public Enum TimerError
    [_Start]
    CreateTimerError = vbObjectError + 1
    '...
    [_End]
End Enum

[_Start] should really be [_Undefined] or [_NoError] with an explicit value of 0, and then a hidden [_BaseError] set to vbObjectError, and then let the VBA compiler deal with the +1 offsets for the visible members: that way none of the visible members have an explicit value, and you can freely reorder them on a whim.


I'm not sure I like the coupling between the lower-level API classes - for example why does TimerRepository.Add take an Object, when it could take a TimerData reference and not need to Set newData = TimerData.Create(callbackWrapper).

That said, the TickerAPI default instance is stateful - while that makes a friendly-looking client code that doesn't need to worry about holding on to an instance of the class, it breaks the object-orientedness of the API... much like UserForm1.Show, you get client code working with objects without realizing - and global state resetting behind your back. I think the public API should just be a standard module, that way there's no implicit global TickerAPI object instance, and the calling code can remain identical:

TickerAPI.StartManagedTimer New SafeTerminatingTimerProc, True, data:="User data!!"

So far so good, I've peeked at the Metronome API and can't wait to review it!

|improve this answer|||||
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.