How to serialize objects in VBA

Generally speaking, VBA doesn’t provide the possibility to serialize objects, and if you are interested in this topic, you might seen quite a few blogs around this thing, and the answer is always the same – generically not possible, period.

But nothing is impossible though. This article describes a workaround which will give you a general way to serialize any type of objects, including those derived from the native VBA classes (e.g. Workbook etc), custom VBA classes and the COM objects.

To test the below approach, create a new Excel workbook, set the security to enabling macros and also to trusting the access to VBA project model (this is important!). Then go to Visual Basic and add a refference to “TypeLib Information” library (Tools ¬ Refferences…). If you cannot find it in the list of available libraries, then please download it and register with regsvr32.exe. After the library is registered, you will be able to add the refference to it as described above.

Add two custom class modules named ChildClass and ParentClass and copy the code from listings 1 and 2 correspondingly. The classes will be used for testing.

Listing 1. “ChildClass” Class Module

1
2
3
4
5
6
Public Name As String
Public CreationDate As Date
 
Sub DoSomething()
    MsgBox "done"
End Sub
Public Name As String
Public CreationDate As Date

Sub DoSomething()
    MsgBox "done"
End Sub

Listing 2. ParentClass Class Module

1
2
3
4
5
6
7
Public Child As New ChildClass
Public Name As String
Public Number As Integer
 
Function GetPi() As Double
    GetPi = 3.14
End Function
Public Child As New ChildClass
Public Name As String
Public Number As Integer

Function GetPi() As Double
    GetPi = 3.14
End Function

Add a new module called TestSerializing and copy the code from listing 3. Change the path and file name if necessary.

Listing 3. TestSerializing Module

1
2
3
4
5
6
7
8
9
Sub testSerialize()
    Dim myObject As New ParentClass
    myObject.Child.CreationDate = Now()
    myObject.Child.Name = "child object"
    myObject.Name = "parent object"
    myObject.Number = 12341
    
    Serialize myObject, "C:\test.xml", False
End Sub
Sub testSerialize()
    Dim myObject As New ParentClass
    myObject.Child.CreationDate = Now()
    myObject.Child.Name = "child object"
    myObject.Name = "parent object"
    myObject.Number = 12341
    
    Serialize myObject, "C:\test.xml", False
End Sub

Add another Module called XmlSerializer and copy the source code from the Listing 4.
Once done, run the testSerialize() macro and enjoy the results.

The syntax of the main procedure which you need to serialize the objects, is following:

1
2
3
Public Sub Serialize(objToSerialize As Object, fileName As String, _
        Optional notEmptyOnly As Boolean = True, _
        Optional maxIterationsLevelNumber As Integer = 10)
Public Sub Serialize(objToSerialize As Object, fileName As String, _
        Optional notEmptyOnly As Boolean = True, _
        Optional maxIterationsLevelNumber As Integer = 10)

where:
objToSerialize represents an object you need to serialize.
fileName is the name of resulting XML file.
notEmptyOnly parameter tells the serializer to save in XML only the object properties that have not-empty values.
maxIterationsLevelNumber limits the level of nested iterations when one object is referencing to another one etc…

Listing 4. XmlSerializer Module

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
'--------------------------------------------------------------------------------
' Author:   Alexey Kudinov
' Date:     Feb 5, 2014
'
' Description:
'           Retrieves all members of the given object and saves them into XML file
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
' Public methods:
'           Public Sub Serialize(objToSerialize As Object, fileName As String, _
'                Optional notEmptyOnly As Boolean = True, _
'                Optional maxIterationsLevelNumber As Integer = 10)
'--------------------------------------------------------------------------------
 
Public arrSerializedObjects() As Object
 
Public Sub Serialize(objToSerialize As Object, fileName As String, _
        Optional notEmptyOnly As Boolean = True, _
        Optional maxIterationsLevelNumber As Integer = 10)
 
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim oFile As Object
    Set oFile = fso.CreateTextFile(fileName, True)
 
    oFile.WriteLine "<?xml version=""1.0""?>"
 
    ReDim arrSerializedObjects(1) As Object
    Set arrSerializedObjects(1) = Nothing
 
    Serialize1 objToSerialize, oFile, notEmptyOnly, maxIterationsLevelNumber, 1
 
    oFile.Close
    Set fso = Nothing
    Set oFile = Nothing
 
End Sub
 
Private Sub Serialize1(o As Object, oFile As Object, _
        notEmptyOnly As Boolean, maxIterationsLevelNumber As Integer, _
        curIterationLevel As Integer)
    
    If curIterationLevel > maxIterationsLevelNumber Then
        Exit Sub
    End If
    
    Dim curObject As Integer
    
    For curObject = 1 To UBound(arrSerializedObjects)
        If arrSerializedObjects(curObject) Is o Then
            Exit Sub
        End If
    Next
    
    ReDim Preserve arrSerializedObjects(UBound(arrSerializedObjects) + 1) As Object
    Set arrSerializedObjects(UBound(arrSerializedObjects)) = o
    
    Dim t As TLI.TLIApplication
    Set t = New TLI.TLIApplication
    
    Dim ti As TLI.TypeInfo
    Set ti = t.InterfaceInfoFromObject(o)
    
    Dim mi As TLI.MemberInfo, i As Long
    
    oFile.WriteLine "<Object class=""" + ti.Name + """>"
    
    For Each mi In ti.Members
        Dim rtype As String
        Select Case mi.InvokeKind
            Case INVOKE_CONST
                rtype = "Const"
            Case INVOKE_EVENTFUNC
                rtype = "Event"
            Case INVOKE_FUNC
                rtype = "Function"
            Case INVOKE_PROPERTYGET
                rtype = "PropertyGet"
            Case INVOKE_PROPERTYPUT
                rtype = "PropertyPut"
            Case INVOKE_PROPERTYPUTREF
                rtype = "PropertyPutRef"
            Case INVOKE_UNKNOWN
                rtype = "Unknown"
        End Select
            
        i = i + 1
        
        Dim ptype As String
        
        Select Case mi.ReturnType.VarType
            Case VT_ARRAY
                ptype = "VT_ARRAY"
            Case VT_BLOB
                ptype = "VT_BLOB"
            Case VT_BLOB_OBJECT
                ptype = "VT_BLOB_OBJECT"
            Case VT_BOOL
                ptype = "VT_BOOL"
            Case VT_BSTR
                ptype = "VT_BSTR"
            Case VT_BYREF
                ptype = "VT_BYREF"
            Case VT_CARRAY
                ptype = "VT_CARRAY"
            Case VT_CF
                ptype = "VT_CF"
            Case VT_CLSID
                ptype = "VT_CLSID"
            Case VT_CY
                ptype = "VT_CY"
            Case VT_DATE
                ptype = "VT_DATE"
            Case VT_DECIMAL
                ptype = "VT_DECIMAL"
            Case VT_DISPATCH
                ptype = "VT_DISPATCH"
            Case VT_EMPTY
                ptype = "VT_EMPTY"
            Case VT_ERROR
                ptype = "VT_ERROR"
            Case VT_FILETIME
                ptype = "VT_FILETIME"
            Case VT_HRESULT
                ptype = "VT_HRESULT"
            Case VT_I1
                ptype = "VT_I1"
            Case VT_I2
                ptype = "VT_I2"
            Case VT_I4
                ptype = "VT_I4"
            Case VT_I8
                ptype = "VT_I8"
            Case VT_INT
                ptype = "VT_INT"
            Case VT_LPSTR
                ptype = "VT_LPSTR"
            Case VT_LPWSTR
                ptype = "VT_LPWSTR"
            Case VT_NULL
                ptype = "VT_NULL"
            Case VT_PTR
                ptype = "VT_PTR"
            Case VT_R4
                ptype = "VT_R4"
            Case VT_R8
                ptype = "VT_R8"
            Case VT_RECORD
                ptype = "VT_RECORD"
            Case VT_RESERVED
                ptype = "VT_RESERVED"
            Case VT_SAFEARRAY
                ptype = "VT_SAFEARRAY"
            Case VT_STORAGE
                ptype = "VT_STORAGE"
            Case VT_STORED_OBJECT
                ptype = "VT_STORED_OBJECT"
            Case VT_STREAM
                ptype = "VT_STREAM"
            Case VT_STREAMED_OBJECT
                ptype = "VT_STREAMED_OBJECT"
            Case VT_UI1
                ptype = "VT_UI1"
            Case VT_UI2
                ptype = "VT_UI2"
            Case VT_UI4
                ptype = "VT_UI4"
            Case VT_UI8
                ptype = "VT_UI8"
            Case VT_UINT
                ptype = "VT_UINT"
            Case VT_UNKNOWN
                ptype = "VT_UNKNOWN"
            Case VT_USERDEFINED
                ptype = "VT_USERDEFINED"
            Case VT_USERDEFINED
                ptype = "VT_USERDEFINED"
            Case VT_VARIANT
                ptype = "VT_VARIANT"
            Case VT_VECTOR
                ptype = "VT_VECTOR"
            Case VT_VOID
                ptype = "VT_VOID"
        End Select
        
        If (mi.InvokeKind = INVOKE_CONST Or mi.InvokeKind = INVOKE_PROPERTYGET _
                And Mid(mi.Name, 1, 1) <> "_") Then
            
            Dim obj As Object
            Set obj = getObject(o, mi.Name)
            If Not (obj Is Nothing) Then
                oFile.WriteLine "<" & rtype & " name=""" & mi.Name & _
                    """ type=""" & ptype & """>"
                Serialize1 obj, oFile, notEmptyOnly, _
                    maxIterationsLevelNumber, curIterationLevel + 1
                oFile.WriteLine "</" & rtype & ">"
            Else
                value = getValue(o, mi.Name)
                If value <> "" Then
                    oFile.WriteLine "<" & rtype & " name=""" & mi.Name & _
                        """ type=""" & ptype & """><![CDATA["
                    oFile.WriteLine value
                    oFile.WriteLine "]]>"
                    oFile.WriteLine "</" & rtype & ">"
                Else
                    If Not notEmptyOnly Then
                        oFile.WriteLine "<" & rtype & " name=""" & mi.Name & _
                            """ type=""" & ptype & """/>"
                    End If
                End If
            End If
        Else
            If Not notEmptyOnly Then
                oFile.WriteLine "<" & rtype & " name=""" & mi.Name & _
                    """ type=""" & ptype & """/>"
            End If
        End If
    Next
    
    oFile.WriteLine "</Object>"
End Sub
 
'---------------------------------------------------------------------------
' returns a value of the property
' where o is a given object, p is a property name (string)
'---------------------------------------------------------------------------
Private Function getValue(o As Object, p As String)
 
    Dim LineNum As Long
    ' create a new module in the current workbook,
    ' enter the code, run and remove the new module
    Set vbp = ActiveWorkbook.VBProject
 
    Set VBComp = ThisWorkbook.VBProject.VBComponents.Add(1)
    VBComp.Name = "NewModule"
    ' add the code lines
    Set VBCodeMod = ThisWorkbook.VBProject.VBComponents("NewModule").CodeModule
    With VBCodeMod
        LineNum = .CountOfLines + 1
        .InsertLines LineNum, _
        "function getObjectPropertyValue(o as Object) As String" & Chr(13) & _
        "on error goto handleErr" & Chr(13) & _
        "getObjectPropertyValue = CStr(o." & p & ")" & Chr(13) & _
        "Exit Function:" & Chr(13) & _
        "handleErr:" & Chr(13) & _
        "getObjectPropertyValue = """"" & Chr(13) & _
        "End Function"
    End With
 
    ' run the new module
    Dim value As String
    value = Application.Run("getObjectPropertyValue", o)
    ' remove the new module
    ThisWorkbook.VBProject.VBComponents.Remove VBComp
    getValue = value
End Function
 
'---------------------------------------------------------------------------
' same as getValue, but returns an object
'---------------------------------------------------------------------------
Private Function getObject(o As Object, p As String) As Object
 
    Dim LineNum As Long
    ' create a new module in the current workbook,
    ' enter the code, run and remove the new module
    Set vbp = ActiveWorkbook.VBProject
 
    Set VBComp = ThisWorkbook.VBProject.VBComponents.Add(1)
    VBComp.Name = "NewModule"
     'add the code lines
    Set VBCodeMod = ThisWorkbook.VBProject.VBComponents("NewModule").CodeModule
    With VBCodeMod
        LineNum = .CountOfLines + 1
        .InsertLines LineNum, _
        "function getObjectPropertyValue(o as Object) As Object" & Chr(13) & _
        "on error goto handleErr" & Chr(13) & _
        "set getObjectPropertyValue = o." & p & Chr(13) & _
        "Exit Function" & Chr(13) & _
        "handleErr:" & Chr(13) & _
        "Set getObjectPropertyValue = Nothing" & Chr(13) & _
        "End Function"
    End With
 
     'run the new module
    Dim value As Object
    Set value = Application.Run("getObjectPropertyValue", o)
     'remove the new module
    ThisWorkbook.VBProject.VBComponents.Remove VBComp
    Set getObject = value
End Function
'--------------------------------------------------------------------------------
' Author:   Alexey Kudinov
' Date:     Feb 5, 2014
'
' Description:
'           Retrieves all members of the given object and saves them into XML file
'--------------------------------------------------------------------------------
'--------------------------------------------------------------------------------
' Public methods:
'           Public Sub Serialize(objToSerialize As Object, fileName As String, _
'                Optional notEmptyOnly As Boolean = True, _
'                Optional maxIterationsLevelNumber As Integer = 10)
'--------------------------------------------------------------------------------

Public arrSerializedObjects() As Object

Public Sub Serialize(objToSerialize As Object, fileName As String, _
        Optional notEmptyOnly As Boolean = True, _
        Optional maxIterationsLevelNumber As Integer = 10)

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim oFile As Object
    Set oFile = fso.CreateTextFile(fileName, True)

    oFile.WriteLine "<?xml version=""1.0""?>"

    ReDim arrSerializedObjects(1) As Object
    Set arrSerializedObjects(1) = Nothing

    Serialize1 objToSerialize, oFile, notEmptyOnly, maxIterationsLevelNumber, 1

    oFile.Close
    Set fso = Nothing
    Set oFile = Nothing

End Sub

Private Sub Serialize1(o As Object, oFile As Object, _
        notEmptyOnly As Boolean, maxIterationsLevelNumber As Integer, _
        curIterationLevel As Integer)
    
    If curIterationLevel > maxIterationsLevelNumber Then
        Exit Sub
    End If
    
    Dim curObject As Integer
    
    For curObject = 1 To UBound(arrSerializedObjects)
        If arrSerializedObjects(curObject) Is o Then
            Exit Sub
        End If
    Next
    
    ReDim Preserve arrSerializedObjects(UBound(arrSerializedObjects) + 1) As Object
    Set arrSerializedObjects(UBound(arrSerializedObjects)) = o
    
    Dim t As TLI.TLIApplication
    Set t = New TLI.TLIApplication
    
    Dim ti As TLI.TypeInfo
    Set ti = t.InterfaceInfoFromObject(o)
    
    Dim mi As TLI.MemberInfo, i As Long
    
    oFile.WriteLine "<Object class=""" + ti.Name + """>"
    
    For Each mi In ti.Members
        Dim rtype As String
        Select Case mi.InvokeKind
            Case INVOKE_CONST
                rtype = "Const"
            Case INVOKE_EVENTFUNC
                rtype = "Event"
            Case INVOKE_FUNC
                rtype = "Function"
            Case INVOKE_PROPERTYGET
                rtype = "PropertyGet"
            Case INVOKE_PROPERTYPUT
                rtype = "PropertyPut"
            Case INVOKE_PROPERTYPUTREF
                rtype = "PropertyPutRef"
            Case INVOKE_UNKNOWN
                rtype = "Unknown"
        End Select
            
        i = i + 1
        
        Dim ptype As String
        
        Select Case mi.ReturnType.VarType
            Case VT_ARRAY
                ptype = "VT_ARRAY"
            Case VT_BLOB
                ptype = "VT_BLOB"
            Case VT_BLOB_OBJECT
                ptype = "VT_BLOB_OBJECT"
            Case VT_BOOL
                ptype = "VT_BOOL"
            Case VT_BSTR
                ptype = "VT_BSTR"
            Case VT_BYREF
                ptype = "VT_BYREF"
            Case VT_CARRAY
                ptype = "VT_CARRAY"
            Case VT_CF
                ptype = "VT_CF"
            Case VT_CLSID
                ptype = "VT_CLSID"
            Case VT_CY
                ptype = "VT_CY"
            Case VT_DATE
                ptype = "VT_DATE"
            Case VT_DECIMAL
                ptype = "VT_DECIMAL"
            Case VT_DISPATCH
                ptype = "VT_DISPATCH"
            Case VT_EMPTY
                ptype = "VT_EMPTY"
            Case VT_ERROR
                ptype = "VT_ERROR"
            Case VT_FILETIME
                ptype = "VT_FILETIME"
            Case VT_HRESULT
                ptype = "VT_HRESULT"
            Case VT_I1
                ptype = "VT_I1"
            Case VT_I2
                ptype = "VT_I2"
            Case VT_I4
                ptype = "VT_I4"
            Case VT_I8
                ptype = "VT_I8"
            Case VT_INT
                ptype = "VT_INT"
            Case VT_LPSTR
                ptype = "VT_LPSTR"
            Case VT_LPWSTR
                ptype = "VT_LPWSTR"
            Case VT_NULL
                ptype = "VT_NULL"
            Case VT_PTR
                ptype = "VT_PTR"
            Case VT_R4
                ptype = "VT_R4"
            Case VT_R8
                ptype = "VT_R8"
            Case VT_RECORD
                ptype = "VT_RECORD"
            Case VT_RESERVED
                ptype = "VT_RESERVED"
            Case VT_SAFEARRAY
                ptype = "VT_SAFEARRAY"
            Case VT_STORAGE
                ptype = "VT_STORAGE"
            Case VT_STORED_OBJECT
                ptype = "VT_STORED_OBJECT"
            Case VT_STREAM
                ptype = "VT_STREAM"
            Case VT_STREAMED_OBJECT
                ptype = "VT_STREAMED_OBJECT"
            Case VT_UI1
                ptype = "VT_UI1"
            Case VT_UI2
                ptype = "VT_UI2"
            Case VT_UI4
                ptype = "VT_UI4"
            Case VT_UI8
                ptype = "VT_UI8"
            Case VT_UINT
                ptype = "VT_UINT"
            Case VT_UNKNOWN
                ptype = "VT_UNKNOWN"
            Case VT_USERDEFINED
                ptype = "VT_USERDEFINED"
            Case VT_USERDEFINED
                ptype = "VT_USERDEFINED"
            Case VT_VARIANT
                ptype = "VT_VARIANT"
            Case VT_VECTOR
                ptype = "VT_VECTOR"
            Case VT_VOID
                ptype = "VT_VOID"
        End Select
        
        If (mi.InvokeKind = INVOKE_CONST Or mi.InvokeKind = INVOKE_PROPERTYGET _
                And Mid(mi.Name, 1, 1) <> "_") Then
            
            Dim obj As Object
            Set obj = getObject(o, mi.Name)
            If Not (obj Is Nothing) Then
                oFile.WriteLine "<" & rtype & " name=""" & mi.Name & _
                    """ type=""" & ptype & """>"
                Serialize1 obj, oFile, notEmptyOnly, _
                    maxIterationsLevelNumber, curIterationLevel + 1
                oFile.WriteLine "</" & rtype & ">"
            Else
                value = getValue(o, mi.Name)
                If value <> "" Then
                    oFile.WriteLine "<" & rtype & " name=""" & mi.Name & _
                        """ type=""" & ptype & """><![CDATA["
                    oFile.WriteLine value
                    oFile.WriteLine "]]>"
                    oFile.WriteLine "</" & rtype & ">"
                Else
                    If Not notEmptyOnly Then
                        oFile.WriteLine "<" & rtype & " name=""" & mi.Name & _
                            """ type=""" & ptype & """/>"
                    End If
                End If
            End If
        Else
            If Not notEmptyOnly Then
                oFile.WriteLine "<" & rtype & " name=""" & mi.Name & _
                    """ type=""" & ptype & """/>"
            End If
        End If
    Next
    
    oFile.WriteLine "</Object>"
End Sub

'---------------------------------------------------------------------------
' returns a value of the property
' where o is a given object, p is a property name (string)
'---------------------------------------------------------------------------
Private Function getValue(o As Object, p As String)

    Dim LineNum As Long
    ' create a new module in the current workbook,
    ' enter the code, run and remove the new module
    Set vbp = ActiveWorkbook.VBProject

    Set VBComp = ThisWorkbook.VBProject.VBComponents.Add(1)
    VBComp.Name = "NewModule"
    ' add the code lines
    Set VBCodeMod = ThisWorkbook.VBProject.VBComponents("NewModule").CodeModule
    With VBCodeMod
        LineNum = .CountOfLines + 1
        .InsertLines LineNum, _
        "function getObjectPropertyValue(o as Object) As String" & Chr(13) & _
        "on error goto handleErr" & Chr(13) & _
        "getObjectPropertyValue = CStr(o." & p & ")" & Chr(13) & _
        "Exit Function:" & Chr(13) & _
        "handleErr:" & Chr(13) & _
        "getObjectPropertyValue = """"" & Chr(13) & _
        "End Function"
    End With

    ' run the new module
    Dim value As String
    value = Application.Run("getObjectPropertyValue", o)
    ' remove the new module
    ThisWorkbook.VBProject.VBComponents.Remove VBComp
    getValue = value
End Function

'---------------------------------------------------------------------------
' same as getValue, but returns an object
'---------------------------------------------------------------------------
Private Function getObject(o As Object, p As String) As Object

    Dim LineNum As Long
    ' create a new module in the current workbook,
    ' enter the code, run and remove the new module
    Set vbp = ActiveWorkbook.VBProject

    Set VBComp = ThisWorkbook.VBProject.VBComponents.Add(1)
    VBComp.Name = "NewModule"
     'add the code lines
    Set VBCodeMod = ThisWorkbook.VBProject.VBComponents("NewModule").CodeModule
    With VBCodeMod
        LineNum = .CountOfLines + 1
        .InsertLines LineNum, _
        "function getObjectPropertyValue(o as Object) As Object" & Chr(13) & _
        "on error goto handleErr" & Chr(13) & _
        "set getObjectPropertyValue = o." & p & Chr(13) & _
        "Exit Function" & Chr(13) & _
        "handleErr:" & Chr(13) & _
        "Set getObjectPropertyValue = Nothing" & Chr(13) & _
        "End Function"
    End With

     'run the new module
    Dim value As Object
    Set value = Application.Run("getObjectPropertyValue", o)
     'remove the new module
    ThisWorkbook.VBProject.VBComponents.Remove VBComp
    Set getObject = value
End Function

6 thoughts on “How to serialize objects in VBA

  1. Thanks Alexey, working well! Could I also deserialize xml to object with this code or how to do that? Cheers Pavel

  2. Hi Pavel, I’m glad it was useful. Unfortunately, TypeLib provides only the possibility to inspect an object, but not to create it. So I’m not sure if there is a general way to create any object out of xml in VBA. But if you know the object structure (i.e. all its members) than you can basically read an XML file for the property values and manually create the object.

Leave a comment

Your email address will not be published. Required fields are marked *