Persisting Variables Over A State Loss

Question

In an application that I built recently, I needed to persist several variables, without loosing their state, for duration that the application was in use. After some research, I found this post on StackOverflow that led me in the right direction and from there I encapsulated that logic into a class.

I have tested this with custom classes and it works as intended. Note that the class is Pre-Declared (i.e. Attribute VB_PredeclaredId = True) because I wanted this to function more or less like Access's TempVars object, which does not have to be "Newed-up" to obtain availability to properties/methods.

To use this class you must add references to the Common Language Runtime Execution Engine 2.4 Library and the mscorlib.dll respectively. Below I have provided the code to the add those pro-grammatically, as neither are easy to find in the References listing.

As for feedback, I am looking to make sure that my implementation is not implicitly causing some sort of a memory leak (kind of an important factor, ha). As per the link posted above, the object should only persist for the duration that Excel is open. That being said, If you plan to use this class in one of your projects, you need to call the RemoveAll method during the Workbook_BeforeClose event. You have to remember that the user may close your application, but leave other instances of Excel open, which means that the AppSessionVariables would still be "alive". If the user were to close excel entirely, then Session Variables would be cleared and you needn't worry, but that's only in a perfect world, and we developers know more than anyone that no such world exists.

Class: AppSessionVariables

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "AppSessionVariables"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True 
Attribute VB_Exposed = False
Option Explicit

Private Const APP_SESSION_VARIABLES_NAME As String = "APP_SESSION_VARIABLES"

Public Enum AppSessionVariablesError
    Error_AlreadyExists = vbObjectError + 1042
    Error_DoesNotExist
End Enum

Private Type TAppSessionVariables
    dictSessionVars As Object
End Type

Private this As TAppSessionVariables

Private Sub Class_Initialize()
    If this.dictSessionVars Is Nothing Then Set this.dictSessionVars = GetPersistentDictionary()
End Sub

Private Function GetPersistentDictionary() As Object

    Dim host As mscoree.CorRuntimeHost
    Dim domain As mscorlib.AppDomain
    Dim dict As Object

        Set host = New mscoree.CorRuntimeHost

        host.Start
        host.GetDefaultDomain domain

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

    Set GetPersistentDictionary = dict

End Function

Public Sub Add(ByVal Name As String, ByVal Value As Variant)
    ThrowIfAlreadyExists Name

    If IsObject(Value) Then
        Set this.dictSessionVars(Name) = Value
    Else
        this.dictSessionVars(Name) = Value
    End If

End Sub

Public Function Exists(ByVal Name As String) As Boolean
    Exists = this.dictSessionVars.Exists(Name)
End Function

Public Sub Remove(ByVal Name As String)
    On Error Resume Next
    this.dictSessionVars.Remove Name
End Sub

Public Sub RemoveAll()
    this.dictSessionVars.RemoveAll
End Sub

Public Function Item(ByVal Name As String) As Variant

    ThrowIfDoesNotExist Name

    If IsObject(this.dictSessionVars(Name)) Then
        Set Item = this.dictSessionVars(Name)
    Else
        Item = this.dictSessionVars(Name)
    End If

End Function

Public Function Count() As Long
    Count = this.dictSessionVars.Count
End Function


Private Sub ThrowIfAlreadyExists(ByVal Name As String)

    If Exists(Name) Then
        Err.Raise AppSessionVariablesError.Error_AlreadyExists, TypeName(Me), _
                  "This Variable already exists."
    End If

End Sub

Private Sub ThrowIfDoesNotExist(ByVal Name As String)

    If Not Exists(Name) Then
        Err.Raise AppSessionVariablesError.Error_DoesNotExist, TypeName(Me), _
                  "This does not exist."
    End If

End Sub

Adding the References:

Place the following in a regular module and runCheckAndFixReferences

Private Const MSCOREE_GUID As String = "{5477469E-83B1-11D2-8B49-00A0C9B7C9C4}"
Private Const MSCOREE_MAJOR_VERSION As Long = 2
Private Const MSCOREE_MINOR_VERSION As Long = 4

Private Const MSCORLIB_GUID As String = "{BED7F4EA-1A96-11D2-8F08-00A0C9A6186D}"
Private Const MSCORLIB_MAJOR_VERSION As Long = 2
Private Const MSCORLIB_MINOR_VERSION As Long = 4

Private Sub CheckAndFixReferences()
    AddIfNotExists MSCOREE_GUID, MSCOREE_MAJOR_VERSION, MSCOREE_MINOR_VERSION
    AddIfNotExists MSCORLIB_GUID, MSCORLIB_MAJOR_VERSION, MSCORLIB_MINOR_VERSION
End Sub

Private Sub AddIfNotExists(ByVal Guid As String, MajorVersion As Long, MinorVersion As Long)

    Const ErrorAlreadyExists As Long = 32813

    On Error GoTo ReferenceAlreadyExists
    ThisWorkbook.VBProject.References.AddFromGuid Guid, MajorVersion, MinorVersion

CleanExit:
    Exit Sub

ReferenceAlreadyExists:
    If Err.Number = ErrorAlreadyExists Then Resume CleanExit
End Sub

Usage:

For the purpose of testing, you can create the following simple class:

**Class: TestClass**

Option Explicit

Private Type TTestClass
    PropertyOne As Boolean
End Type

Private this As TTestClass

Public Property Let PropertyOne(ByVal value As Boolean)
    this.PropertyOne = value
End Property

Public Property Get PropertyOne() As Boolean
    PropertyOne = this.PropertyOne
End Property

And then place and run the following subs in a module:

Private Sub SetVariable()

    Dim TestObject As TestClass

    Set TestObject = New TestClass
        TestObject.PropertyOne = True

    If Not AppSessionVariables.Exists("TestObject") Then 
        AppSessionVariables.Add "TestObject", TestObject
    End If 

    If Not AppSessionVariables.Exists("TestVar") Then 
        AppSessionVariables.Add "TestVar", "TestVar"
    End If 


End Sub

Private Sub GetVariable()

    Debug.Assert AppSessionVariables.Item("TestObject").PropertyOne

    Debug.Print AppSessionVariables.Item("TestVar")

    AppSessionVariables.RemoveAll

End Sub

Answer 1

The dictSessionVars is initialized together with the default instance of the class:

Private Sub Class_Initialize()
    If this.dictSessionVars Is Nothing Then Set this.dictSessionVars = GetPersistentDictionary()
End Sub

That's great, because it ensures you always have a valid managed storage.

That being said, If you plan to use this class in one of your projects, you need to call the RemoveAll method during the Workbook_BeforeClose event.

Ok. Consider this code:

Dim borked As AppSessionVariables
Set borked = New AppSessionVariables '<~ initialize handler runs here, before LHS gets the reference

borked.Add "Leak", "Leak"
Set borked = Nothing '<~ no terminate handler, any instance state is leaked memory

Set borked = AppSessionVariables '<~ default instance ref.
borked.Add "Leak?", "Leak?"
Set borked = Nothing '<~ instance state is destroyed, but managed AppDomain is still up

'initialize handler runs again here, before .Add is invoked:
borked.Add "Leak?", "Leak?" '<~ should fail to add existing key

How many CorRuntimeHost instances are running at that point?

I think the class should have a Terminate handler, and the CorRuntimeHost object reference should be persisted at instance level, and cleanly stopped in the terminate handler.

The class should throw errors if it is initialized as a non-default instance. That way Set foo = New AppSessionVariables would throw an error before foo even gets ahold of the object reference, and a new CorRuntimeHost wouldn't be created in that case; invoking this upon entering any Public member should do:

Private Sub ThrowIfNonDefaultInstance()
    If Not Me Is AppSessionVariables Then
        Err.Raise AppSessionVariablesError.Error_NonDefaultInstance, Typename(Me), "Use the default instance, not a new one."
    End If
End Sub

I am looking to make sure that my implementation is not implicitly causing some sort of a memory leak

The problem is that the memory leak is pretty much a feature here: you want the data to outlive your class instance.

I've personally never encountered a single use case for this behavior in over 20 years of VBA programming. IMO data that outlives the class that creates it, is by definition a memory leak, and thus boils down to being a Bad Idea™.

When VBA code does this:

Set thing = Nothing

The VBA dev has every reason on Earth to believe they have effectively destroyed the object and its encapsulated state.

Even worse - when this instruction is encountered:

End

VBA devs should expect all global state to cleanly reset.

By design, this AppSessionVariables thwarts these fundamental expectations, and this can easily make using this class more error-prone than it needs to be.

Answer 2

My tests indicate that adding an instance of TTestClass to the AppSessionVariables Dictionary does not survive a state loss.

Private Sub SetVariable()
    Rem ...Code
    End

End Sub

Adding End to SetVariable and then calling GetVariable throws this error:

Simple Key/Value pairs do, however, persist. The values persist even after closing and reopening the workbook. Closing the Excel.Application destroys the reference.

Saving and Restoring the Object's State

It should be the responsibility of the class to determine how to save and restore its state. This will not only make it easier to implement but will also allow you to store private field values.

All the classes to be saved should Implement a common Interface which defines the methods used to save and restore the settings. Having each object store its setting in its own dictionary and adding the objects dictionary to the AppSessionVariables's persistent dictionary will encapsulate the objects settings making it easier to work with.

To test my design I created an IVBASerializable Interface and two classes that Implement it. The classes are successfully saved and restored as long as the application is not closed.

Interface: IVBASerializable

Attribute VB_Name = "IVBASerializable"

Option Explicit

Public Function Save() As Boolean
End Function

Public Function Restore() As Boolean
End Function

Public Property Get Guid() As String
End Property

Public Property Let Guid(ByVal Value As String)
End Property

Public Property Get ToString() As String
End Property

Public Property Get ClassName() As String
End Property

Class: SerializableRange

Attribute VB_Name = "SerializableRange"

Option Explicit
Implements IVBASerializable

Private Type Members
    RangeExternalAddress As String
End Type

Private this As Members
Private Created As Date
Public Guid As String

Private Sub Class_Initialize()
    Created = Date
End Sub

Public Property Get ClassName() As String
    ClassName = TypeName(Me)
End Property

Private Property Get IVBASerializable_ClassName() As String
    IVBASerializable_ClassName = ClassName
End Property

Private Property Get IVBASerializable_Guid() As String
    IVBASerializable_Guid = Guid
End Property

Private Property Let IVBASerializable_Guid(ByVal Value As String)
    Guid = Value
End Property

Private Property Get IVBASerializable_ToString() As String
    Dim Values(3) As String
    Values(0) = "Address: " & this.RangeExternalAddress
    Values(1) = "Row Count: " & Range.Rows.Count
    Values(2) = "Column Count: " & Range.Columns.Count
    Values(3) = "Created: " & Created

    IVBASerializable_ToString = Join(Values, vbNewLine)
End Property

Public Property Get Range() As Range
    Set Range = Application.Range(this.RangeExternalAddress)
End Property

Public Property Let Range(ByVal newRange As Range)
    this.RangeExternalAddress = newRange.Address(External:=True)
End Property

Public Property Get Self() As SerializableRange
    Set Self = Me
End Property



Private Function IVBASerializable_Restore() As Boolean
    IVBASerializable_Restore = Restore
End Function

Private Function IVBASerializable_Save() As Boolean
    IVBASerializable_Save = Save
End Function

Public Function Restore() As Boolean
    If AppSessionVariables.Exists(Guid) Then
        Dim Map As Scripting.Dictionary
        Set Map = AppSessionVariables.Item(Guid)
        Map("Created") = Created
        this.RangeExternalAddress = Map("RangeExternalAddress")
    End If
End Function

Public Function Save() As Boolean
    If Len(Guid) > 0 Then
        Dim Map As New Scripting.Dictionary
        Map("RangeExternalAddress") = this.RangeExternalAddress
        Map("Created") = Created
        AppSessionVariables.Add Guid, Map
    End If
End Function

Class: SerializableSize

Attribute VB_Name = "SerializableSize"

Option Explicit
Implements IVBASerializable

Private Type Members
    Guid As String
    Shape As Shape
End Type

Private this As Members
Public Guid As String
Private Created As Date
Public Width As Single
Public Height As Single

Private Sub Class_Initialize()
    Created = Date
End Sub

Public Property Get ClassName() As String
    ClassName = TypeName(Me)
End Property

Private Property Get IVBASerializable_ClassName() As String
    IVBASerializable_ClassName = ClassName
End Property

Private Property Get IVBASerializable_Guid() As String
    IVBASerializable_Guid = Guid
End Property

Private Property Let IVBASerializable_Guid(ByVal Value As String)
    Guid = Value
End Property

Private Property Get IVBASerializable_ToString() As String
    Dim Values(2) As String
    Values(0) = "Width: " & Width
    Values(1) = "Height: " & Height
    Values(2) = "Created: " & Created

    IVBASerializable_ToString = Join(Values, vbNewLine)
End Property

Public Property Get Self() As SerializableSize
    Set Self = Me
End Property

Private Function IVBASerializable_Restore() As Boolean
    IVBASerializable_Restore = Restore
End Function

Private Function IVBASerializable_Save() As Boolean
    IVBASerializable_Save = Save
End Function

Public Function Restore() As Boolean
    If AppSessionVariables.Exists(Guid) Then
        Dim Map As Scripting.Dictionary
        Set Map = AppSessionVariables.Item(Guid)
        Width = Map("Width")
        Height = Map("Height")
    End If
End Function

Public Function Save() As Boolean
    If Len(Guid) > 0 Then
        Dim Map As New Scripting.Dictionary
        Map("Created") = Created
        Map("Width") = Width
        Map("Height") = Height
        AppSessionVariables.Add Guid, Map
    End If
End Function

UnitTest

Option Explicit
Public Enum DefaultSerializables
    Range1
    Range2
    Size1
    Size2
    [_First] = Range1
    [_Last] = Size2
End Enum

Public Serializables() As IVBASerializable

Public Sub TestPart1()
    InitSerializables
    SaveSerializables
    Debug.Print "TestPart1"
    PrintSerializables
    Erase Serializables
    End
End Sub

Public Sub TestPart2()
    Debug.Print
    Debug.Print "TestPart2"
    RestoreSerializables
    PrintSerializables
End Sub

Private Sub InitSerializables()
    ReDim Serializables(0 To DefaultSerializables.[_Last])

    With New SerializableRange
        Set Serializables(Range1) = .Self
        .Guid = .ClassName & ";" & Range1
        .Range = Sheet1.Range("A1:C20")
    End With

    With New SerializableRange
        Set Serializables(Range2) = .Self
        .Guid = .ClassName & ";" & Range2
        .Range = Sheet1.Range("AA1:AC20")
    End With

    With New SerializableSize
        Set Serializables(Size1) = .Self
        .Guid = .ClassName & ";" & Size1
        .Height = Sheet1.Shapes(1).Height
        .Width = Sheet1.Shapes(1).Width
    End With

     With New SerializableSize
        Set Serializables(Size2) = .Self
        .Guid = .ClassName & ";" & Size2
        .Height = Sheet1.Shapes(2).Height
        .Width = Sheet1.Shapes(2).Width
    End With

End Sub

Sub SaveSerializables()
    Dim n As Long
    For n = DefaultSerializables.[_First] To DefaultSerializables.[_Last]
        Serializables(n).Save
    Next
End Sub

Sub RestoreSerializables()
    ReDim Serializables(0 To DefaultSerializables.[_Last])

    With New SerializableRange
        Set Serializables(Range1) = .Self
        .Guid = .ClassName & ";" & Range1
        .Restore
    End With

    With New SerializableRange
        Set Serializables(Range2) = .Self
        .Guid = .ClassName & ";" & Range2
        .Restore
    End With

    With New SerializableSize
        Set Serializables(Size1) = .Self
        .Guid = .ClassName & ";" & Size1
        .Restore
    End With

     With New SerializableSize
        Set Serializables(Size2) = .Self
        .Guid = .ClassName & ";" & Size2
        .Restore
    End With
End Sub

Sub PrintSerializables()
    Dim n As Long
    For n = DefaultSerializables.[_First] To DefaultSerializables.[_Last]
        Debug.Print Serializables(n).ToString
    Next
End Sub

Test Results