Very weird bug when passing references to custom classes vs built-in objects

Question

I am trying to do some trickery with the SetTimer api, and have finally been able to create a reproducible example for a problem I've been stuck with. I'm getting an error when I pass an instance of a custom class to a callback, but not for built-in/ library classes

Here's what I'm trying to do:

1. Create a timer with a callback function using the SetTimer function
2. Pass some data to the callback by setting the timerID (UINT_PTR nIDEvent in the docs) to be a pointer to an object which wraps the data
3. Persist the argument object in memory over a state loss (hitting the stop button in the editor) using an mscorlib.AppDomain

---

To expand on those points a bit:

1. Creating the timer

No problems here; below are my api declarations, which I've put in a module called WinAPI

Public Declare Function SetTimer Lib "user32" ( _
                        ByVal hWnd As LongPtr, _
                        ByVal nIDEvent As LongPtr, _
                        ByVal uElapse As Long, _
                        ByVal lpTimerFunc As LongPtr) As LongPtr

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

2. Pass data

I've defined a callback function signature which is compliant with the TIMERPROC definition

Private Sub timerProc(ByVal windowHandle As LongPtr, ByVal message As Long, ByVal timerObj As Object, ByVal tickCount As Long)

As you can see the third argument _In_ UINT_PTR idEvent, which is usually the plain id of the WinAPI timer, is here being used to pass a reference to some object in memory. In my actual code this is a strongly typed custom class, but for this example Object will suffice.

I then create the timer using

Dim timerParams As Object
'... initialise the object with the data to pass
SetTimer hWnd:=Application.hWnd, nIDEvent:=ObjPtr(timerParams), uElapse:=500, lpTimerFunc:=AddressOf timerProc

(ok I don't use all the named arguments like that, but you get the idea;)

3. Persist Data

In my real code (sorry, not in this example), I already have some bits and pieces hooked up so that hitting the stop button will trigger the timer to be stopped, however it still gets one more tick before it is destroyed with KillTimer. Therefore it's crucial that my object gets persisted in memory even when I hit stop in the editor - if not then when the timerProc runs for the final time, the pointer it tries to dereference will be invalid.

Basically I always have to make sure that timerObj exists whenever timerProc is called. The WinAPI timers don't get destroyed when I press Stop in my VBA code, so my object mustn't be either. For that reason I'm using the approach suggested in this answer

---

The Issue

Right, putting all that together to create an MRE (or whatever the acronym is now):

Option Explicit

Private Declare Function SetTimer Lib "user32" ( _
                         ByVal hWnd As LongPtr, _
                         ByVal nIDEvent As LongPtr, _
                         ByVal uElapse As Long, _
                         ByVal lpTimerFunc As LongPtr) As LongPtr

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

Private Function GetPersistentDictionary() As Object
    ' References:
    '  mscorlib.dll
    '  Common Language Runtime Execution Engine

    Const name = "weak-data"
    Static dict As Object

    If dict Is Nothing Then
        Dim host As New mscoree.CorRuntimeHost
        Dim domain As mscorlib.AppDomain
        host.Start
        host.GetDefaultDomain domain

        If IsObject(domain.GetData(name)) Then
            Set dict = domain.GetData(name)
        Else
            Set dict = CreateObject("Scripting.Dictionary")
            domain.SetData name, dict
        End If
    End If

    Set GetPersistentDictionary = dict
End Function

Private Sub timerProc(ByVal windowHandle As LongPtr, ByVal message As Long, ByVal timerObj As Object, ByVal tickCount As Long)

    Static i As Long 'this will go to zero after a state-loss
    i = i + 1
    Debug.Print i;
    Dim data As String
    data = timerObj.Item("myVal")
    Debug.Print data
    If i >= 10 Then
        KillTimer Application.hWnd, ObjPtr(timerObj)
        Debug.Print "Done"
        i = 0
    End If
End Sub

Private Sub setUpTimer()
    'create the data to pass to the callback function
    Dim testObj As Object
    Set testObj = New Dictionary
    testObj.Item("myVal") = "I'm the data you passed!"

    'store the data object in cache so its reference count never goes to zero
    Dim cache As Dictionary
    Set cache = GetPersistentDictionary()
    Set cache.Item("testObj") = testObj

    'create the timer, passing the data object as an argument
    SetTimer Application.hWnd, ObjPtr(testObj), 500, AddressOf timerProc
End Sub

And that actually works exactly as expected! The output is something like this:

 1 I'm the data you passed!
 2 I'm the data you passed!
 3 I'm the data you passed!
 4 I'm the data you passed!
 5 I'm the data you passed! '<- I pressed stop just after this, which restarted the static count, but didn't destroy the cached object
 1 I'm the data you passed!
 2 I'm the data you passed!
 3 I'm the data you passed!
 4 I'm the data you passed!
 5 I'm the data you passed!
 6 I'm the data you passed!
 7 I'm the data you passed!
 8 I'm the data you passed!
 9 I'm the data you passed!
 10 I'm the data you passed!
Done

However if I try this with a custom class instead of the Scripting.Dictionary as the data (save before attempting):

Private Sub setUpTimer()
    'create the data to pass to the callback function
    Dim testObj As Object
    Set testObj = New fakeDictionary '<-custom class, the only change
    testObj.Item("myVal") = "I'm the data you passed!"
    '...everything else the same

Where fakeDictionary is just this:

Option Explicit

Private dict As New Scripting.Dictionary

Public Property Get Item(ByVal key As String) As String
    Item = dict.Item(key)
End Property

Public Property Let Item(ByVal key As String, ByVal value As String)
    dict.Item(key) = value
End Property

Private Sub Class_Terminate()
    Debug.Print "I am made dead"
End Sub

I get this upon stopping the code:

And then Excel crashes when the next timer message comes in and runs the callback and the exception is unhandled.

The text reads

Run Time error -2147418105

Automation error

The callee (server [not server application]) is not available and disappeared; all connections are invalid. The call may have executed.

Answer 1

Well, if you press Stop then I do not think it reasonable to expect pointers to objects created from your VBA defined classes to continue to be valid. For a really durable class you'll need to write it in C# (or C++ or Python, or even VB6).