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
Que bien mil gracias por tu ayuda…..aunque el error me sale en acces
What type of the error do you get?
Thanks Alexey, working well! Could I also deserialize xml to object with this code or how to do that? Cheers Pavel
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.
Hey Alexey,
You can use TLI to get the object property values in a more elegant way via the invokehook method. See here:
http://www.tek-tips.com/viewthread.cfm?qid=523068
@PJ: thanks, very useful article.