Use AppDomain to store CoTaskMemAlloc pointers over a state loss VBA

62 Views Asked by At

I am using some code in VBA that relies on CoTaskMemAlloc to create a COM object which won't have its memory released unexpectedly when VBA clears its variables. However I've noticed that if I use End then the IUnknown::Release method of the lightweight COM object that calls CoTaskMemFree never runs. (Basically the code in this post will have a memory leak I want to fix https://stackoverflow.com/a/52261687/6609896)

To avoid the memory leak, I thought at least I could save the pointers to the allocated memory in the AppDomain, and then next time VBA is run, if any pointers are left behind they get cleaned up. I came up with the following:

'@Folder("Implementation")
'@PredeclaredID
Option Explicit

Private Declare PtrSafe Function CoTaskMemAlloc Lib "ole32" (ByVal byteCount As LongPtr) As LongPtr
Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal pMemory As LongPtr)

Private localCacheInstance As Collection
Private Const name As String = "d5167d32-602c-4375-8eed-6ed642cad409" 'use ps [guid]::NewGuid() to avoid name clashes

Private Property Get defaultAppDomain() As AppDomain
    Static host As New mscoree.CorRuntimeHost
    Static result As mscorlib.AppDomain
    If result Is Nothing Then
        host.Start
        host.GetDefaultDomain result
    End If
    Set defaultAppDomain = result
End Property

Private Property Get openMemoryAddresses() As Collection
    ' References:
    '  mscorlib.dll
    '  Common Language Runtime Execution Engine
    If localCacheInstance Is Nothing Then
        With defaultAppDomain
            'if collection not in cache then regenerate it
            If IsObject(.GetData(name)) Then
                'save it to a local copy for faster access (so we don't keep going through appDomain)
                Set localCacheInstance = .GetData(name)
            Else
                Set localCacheInstance = New Collection
                .SetData name, localCacheInstance
            End If
        End With
    End If

    Set openMemoryAddresses = localCacheInstance
End Property

Public Function MemAlloc(ByVal cb As LongPtr) As LongPtr
    MemAlloc = CoTaskMemAlloc(cb)
    Debug.Print "Alloc "; MemAlloc
    openMemoryAddresses.Add MemAlloc
End Function

Public Sub FreeAll()
    'This is idempotent so can be called twice in a row without breaking anything
    Dim addr As Variant
    For Each addr In openMemoryAddresses
        Debug.Print "Free "; addr
        CoTaskMemFree addr
    Next addr
    
    'to avoid double releasing memory next time we're called, we must clear the reference
    resetCache
End Sub

Private Sub resetCache()
    defaultAppDomain.SetData name, Empty
    Set localCacheInstance = Nothing
End Sub

Private Sub Class_Initialize()
    If Not Me Is CoTaskAllocator Then Err.Raise vbObjectError + 1, , "You cannot instantiate a new " & TypeName(Me) & ", use the predeclared instance"
    FreeAll
End Sub

Private Sub Class_Terminate()
    FreeAll
End Sub

I do not know how to debug memory leaks like this, does my approach seem sound? Is there a simpler approach? Am I understanding the semantics of CoTaskMemAlloc, that while Excel.exe is running, the appdomain and the memory allocated will remain live.


N.b. The code is used like this


Dim pMemory1 As LongPtr = CoTaskAllocator.MemAlloc(18)

'... Stop Button

Dim pMemory2 As LongPtr = CoTaskAllocator.MemAlloc(34) 'will free pMemory1 if still around
0

There are 0 best solutions below