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