I've created a fake WeakReference class for VBA by chance. A Weak Reference is not counted (i.e. IUnknown::AddRef method is not called). I knew about the Weak Reference concept from Swift and I accidentaly read about a COM Variant.
In short, I am using a Variant (ByRef) to manipulate the first 2 bytes (var type) in a second Variant in order to flip between an Object and a Long/LongLong Variant.
The advantage of this approach is that only some inital API calls are needed to set things up. When the referenced object is needed only plain VBA calls are done thus making code fast even if called millions of times. Also, the 'Object' property safely returns Nothing if the referenced object has been destroyed already. Finally, because the Variants used are ByRef, the Application can safely clean up memory even if state is lost.
The full code with explanation is under MIT license on GitHub at VBA-WeakReference. I've been asked by Greedquest to post the code here on Code Review. So, here it is:
WeakReference
class:
Option Explicit
#If Mac Then
#If VBA7 Then
Private Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As LongPtr) As LongPtr
#Else
Private Declare Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As Long) As Long
#End If
#Else 'Windows
'https://msdn.microsoft.com/en-us/library/mt723419(v=vs.85).aspx
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End If
#End If
'https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-oaut/3fe7db9f-5803-4dc4-9d14-5425d3f5461f
'https://docs.microsoft.com/en-us/windows/win32/api/oaidl/ns-oaidl-variant?redirectedfrom=MSDN
'Flag used to simulate ByRef Variants in order to avoid memory reclaim
Private Const VT_BYREF As Long = &H4000 'Makes it all possible
'A memory address Long Integer
Private Type MEM_ADDRESS
#If VBA7 Then
ptr As LongPtr 'Defaults to LongLong on x64 or Long on x32
#Else
ptr As Long 'For VB6
#End If
End Type
Private Type FAKE_REFERENCE
remoteVarType As Variant 'Manipulates the variant type for 'reference'
reference As Variant 'Will be holding the object reference/address
vTable As MEM_ADDRESS 'Initial address of virtual table
vTableByRef As Variant 'Address used to check if reference is still valid
vbLongPtr As Long 'Data type enum (vbLong = 3 or vbLongLong = 20)
isValid As Boolean 'Indicates if the memory reference is valid
End Type
Private m_fake As FAKE_REFERENCE
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Class Constructor
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Sub Class_Initialize()
'Save address of the Variant that will hold the target reference/address
m_fake.remoteVarType = VarPtr(m_fake.reference)
'
'Change remoteVT variant type to Integer ByRef. This will now be linked
' to the first 2 bytes of the Variant holding the target reference
'Setting the VT_BYREF flag makes sure that the 2 bytes are not reclaimed
' twice when both 'remoteVarType' and 'reference' go out of scope
'And most importantly this gives the ability to switch the variant type of
' the reference at will, just by changing the Integer value of remoteVT
CopyMemory ByVal VarPtr(m_fake.remoteVarType), vbInteger + VT_BYREF, 2
'
'Store the data type enum for mem addresses (vbLong = 3 or vbLongLong = 20)
m_fake.vbLongPtr = VBA.VarType(ObjPtr(Nothing))
End Sub
'*******************************************************************************
'Sets the weak/fake reference to an object
'*******************************************************************************
Public Property Let Object(obj As Object)
'Save memory address of the object
m_fake.reference = ObjPtr(obj)
'
m_fake.isValid = (m_fake.reference <> 0)
If Not m_fake.isValid Then Exit Property
'
'Save the default interface's virtual table address by reference. The vTable
' address is found at the first 4 (x32) or 8 (x64) bytes at the referenced
' interface address
m_fake.vTableByRef = m_fake.reference
CopyMemory ByVal VarPtr(m_fake.vTableByRef), m_fake.vbLongPtr + VT_BYREF, 2
'
'Save the current vTable address. This is needed later to compare with the
' vTableByRef address in order to establish if the Object has been
' destroyed and it's memory reclaimed.
'vTableByRef can still be read within the scope of this method
m_fake.vTable.ptr = m_fake.vTableByRef
End Property
'*******************************************************************************
'Safely retrieves the object that the saved reference is pointing to
'No external API calls are needed!
'*******************************************************************************
Public Property Get Object() As Object
If Not m_fake.isValid Then Exit Property
'
'Compare the current vTable address value with the initial address
'The current redirected value vTableByRef can NOT be read directly anymore
' so it must be passed ByRef to an utility function
m_fake.isValid = (GetRemoteAddress(m_fake.vTableByRef).ptr = m_fake.vTable.ptr)
'
If m_fake.isValid Then
'Address is still valid. Retrive the object
'Turn the reference into an object (needs to be done ByRef)
VarType(m_fake.remoteVarType) = vbObject
Set Object = m_fake.reference
End If
'
'The fake object is not counted (reference count was never incremented by
' calling the IUnknown::AddRef method) so a crash will occur if the
' Variant type remains as vbObject, because when the Variant goes out
' of scope the object count is decremented one more time than it should
'Meanwhile, as Integer, the Variant can safely go out of scope anytime
VarType(m_fake.remoteVarType) = m_fake.vbLongPtr 'vbLong or vbLongLong
End Property
'*******************************************************************************
'Utility. Changes the data type for the reference Variant while preserving the
' level of redirection of remoteVarType
'*******************************************************************************
Private Property Let VarType(ByRef v As Variant, newType As Integer)
v = newType
End Property
'*******************************************************************************
'Returns the value of a Variant that has the VT_BYREF flag set
'*******************************************************************************
Private Function GetRemoteAddress(ByRef memAddress As Variant) As MEM_ADDRESS
GetRemoteAddress.ptr = memAddress
End Function
Can this code be better?
A quick demo showing how a reference cycle can be avoided:
DemoParent
class:
Option Explicit
Private m_child As DemoChild
Public Property Let Child(ch As DemoChild)
Set m_child = ch
End Property
Public Property Get Child() As DemoChild
Set Child = m_child
End Property
Private Sub Class_Terminate()
Set m_child = Nothing
Debug.Print "Parent terminated " & Now
End Sub
And a DemoChild
class:
Option Explicit
Private m_parent As WeakReference
Public Property Let Parent(newParent As DemoParent)
Set m_parent = New WeakReference
m_parent.Object = newParent
End Property
Public Property Get Parent() As DemoParent
Set Parent = m_parent.Object
End Property
Private Sub Class_Terminate()
Debug.Print "Child terminated " & Now
End Sub
Here's a demo:
Sub DemoTerminateParentFirst()
Dim c As New DemoChild
Dim p As New DemoParent
'
p.Child = c
c.Parent = p
'
Debug.Print TypeName(p.Child.Parent)
End Sub
And another demo:
Sub DemoTerminateChildFirst()
Dim c As New DemoChild
Dim p As New DemoParent
'
p.Child = c
c.Parent = p
Set c = Nothing
'
Debug.Print TypeName(p.Child.Parent)
End Sub
Both Parent and Child Class_Terminate events are firing properly.
Updated version and more demos are available at the GitHub repository VBA-WeakReference.