VBA Excel Сохранение пользовательских данных в CustomXMLParts

Option Explicit
'Wrapper class for ThisWorkbook.CustomXMLParts
Private customXMLstorage As Object

Private nameSpace1 As String

Private Const nSpPrefixXML = "cxs"

'****
Private Sub Class_Initialize()
    Set customXMLstorage = ThisWorkbook.CustomXMLParts
        nameSpace1 = "CXStorage"
End Sub

Private Sub Class_Terminate()
    Set customXMLstorage = Nothing
        nameSpace1 = Empty
End Sub

'****
Private Sub InitStorageNameSpace(ByVal value1 As String)
    'if need more then one storage -> Public this
    nameSpace1 = value1
End Sub

'**
Public Function RemoveCustomXMLstorage() As Boolean
On Error GoTo Err
    If MsgBox("You will remove all stored data!", vbOKCancel) = vbCancel Then Exit Function
    '**
    Dim oPart
    For Each oPart In ThisWorkbook.CustomXMLParts.SelectByNamespace(nameSpace1)
        oPart.Delete
    Next
    Set oPart = Nothing
    RemoveCustomXMLstorage = True
    Exit Function
Err:
    RemoveCustomXMLstorage = False
End Function

Public Sub AddItem(ByVal itemName1 As String, ByVal value1 As String)
    '**
    With GetItemsNode()
        With .SelectNodes("//item[@name='" & itemName1 & "']")
            If .Count > 0 Then .item(1).Delete
        End With
        '**
        .AppendChildNode "item", , msoCustomXMLNodeElement
        '**
        With .LastChild
            .AppendChildNode "name", , msoCustomXMLNodeAttribute, itemName1
            .AppendChildNode , , msoCustomXMLNodeText, value1
        End With
        '**
    End With
End Sub

Public Function AddItems(ByRef cItems As Scripting.Dictionary) As Boolean
On Error GoTo Err
    Dim itemName1
    For Each itemName1 In cItems
        AddItem itemName1, cItems(itemName1)
    Next itemName1
    AddItems = True
    Exit Function
Err:
    AddItems = False
End Function

Public Function ItemExists(ByVal itemName1 As String) As Boolean
    ItemExists = Not (GetItemsNode().SelectSingleNode("//item[@name='" & itemName1 & "']") Is Nothing)
End Function

Public Function GetItem(ByVal itemName1 As String) As Variant
    With GetItemsNode().SelectNodes("//item[@name='" & itemName1 & "']")
        If .Count > 0 Then
            If Not (.item(1).FirstChild Is Nothing) Then
                GetItem = .item(1).FirstChild.NodeValue
            End If
        End If
    End With
End Function

Public Function GetItems() As Scripting.Dictionary
    Dim oNode
    Set GetItems = CreateObject("Scripting.Dictionary")
    '**
    For Each oNode In GetItemsNode().SelectNodes("//item")
        GetItems.item(oNode.Attributes.item(1).NodeValue) = oNode.FirstChild.NodeValue
    Next oNode
    '**
    Set oNode = Nothing
End Function

Public Function RemoveItem(ByVal itemName1 As String) As Boolean
    If ItemExists(itemName1) Then
        With GetItemsNode().SelectNodes("//item[@name='" & itemName1 & "']")
            If .Count > 0 Then .item(1).Delete
            RemoveItem = True
        End With
    End If
End Function

Private Function GetItemsNode() As Object
    With ThisWorkbook.CustomXMLParts.SelectByNamespace(nameSpace1)
        If .Count = 0 Then ThisWorkbook.CustomXMLParts.Add "<" & nSpPrefixXML & ":root xmlns:" & nSpPrefixXML & "='" & nameSpace1 & "'><items/></" & nSpPrefixXML & ":root>"
        Set GetItemsNode = .item(1).DocumentElement.FirstChild
    End With
End Function

Option Explicit

Private Sub Test_CustomXMLstorageCls()
    '**
    Dim sv1 As CustomXMLstorageCls
    Set sv1 = New CustomXMLstorageCls
    '**
        sv1.RemoveCustomXMLstorage
    '**
        sv1.AddItem "MyItem", "MyValue"
        sv1.AddItem "MyXml", "<node>text</node>"
        sv1.AddItem "MyText", "Line #1" & vbCrLf & "Line #2" & vbCrLf & "Line #3"
        sv1.AddItem Empty, "Empty"
    '**
    DebugPrintDictColl sv1.GetItems
    '**
        sv1.RemoveCustomXMLstorage
    '**
    Set sv1 = Nothing
    '**
End Sub

Private Sub Test_CustomXMLstorageAdd_CapacityTest()
    '**
    Dim sv1 As CustomXMLstorageCls
    Set sv1 = New CustomXMLstorageCls
    '**
    With CreateObject("Scripting.Dictionary")
        Do
            .item(.Count) = GetGUID 'CreateGUID 'Mid(typeLib1.GUID, 1, 38)
        Loop Until .Count = 100000
        '**
        sv1.AddItem "CapacityTest", Join(.items(), "; ")
    End With
    '**
    Logg "Stored string length: " & Len(sv1.GetItem("CapacityTest")), True, False, True
    '**
        sv1.RemoveCustomXMLstorage
    Set sv1 = Nothing
    '**
End Sub

'****
Private Function GetGUID() As String
  GetGUID = "xxxxxxxx-xxxx-4xxx-yxxx-xxxxxxxxxxxx"
  GetGUID = Replace(GetGUID, "y", Hex(Rnd() And &H3 Or &H8))
  Dim i As Long
  For i = 1 To 30
    GetGUID = Replace(GetGUID, "x", Hex$(CLng(Rnd() * 15.9999)), 1, 1)
  Next i
End Function

Private Function DebugPrintDictColl(ByRef obj1 As Object) As Boolean
    If obj1 Is Nothing Then Debug.Print "The object Is Nothing": Exit Function
    If obj1.Count = 0 Then Debug.Print "The object does not have items": Exit Function
    '**
    Dim i As Long, key1
    '**
    If TypeOf obj1 Is Scripting.Dictionary Then
        For Each key1 In obj1.keys
            i = i + 1
            If TypeOf obj1.item(key1) Is Object  Then
                Debug.Print i & " key: " & key1 & vbTab & " -> item TypeName: " & TypeName(obj1.item(key1))
            Else
                Debug.Print i & " key: " & key1 & vbTab & " -> item: " & obj1.item(key1)
            End If
        Next key1
    Else
        'collection
        Dim itm1
        For Each itm1 In obj1
            i = i + 1
            If Not TypeName(itm1) = "String" And Not TypeName(itm1) = "Long" Then
                Debug.Print i & " key: " & itm1.key & " -> item TypeName: " & TypeName(itm1)
            Else
                Debug.Print i & " key number: " & i & " -> item: " & itm1
            End If
        Next itm1
        Set itm1 = Nothing
    End If
    DebugPrintDictColl = True
End Function

Private Sub Logg(ByVal str1 As String, Optional ByVal debugPrint1 As Boolean = True, Optional ByVal statusBar1 As Boolean, Optional ByVal msgBox1 As Boolean)
    If Len(str1) = 0 Then Exit Sub
    If debugPrint1 Then Debug.Print str1
    If statusBar1 Then Application.StatusBar = str1
    If msgBox1 Then MsgBox str1, vbOKOnly
End Sub