1 (изменено: omegastripes, 2019-01-18 03:08:56)

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

Всем привет! Хочу поделиться кодом, позволяющим хранить произвольные текстовые данные в коллекции CustomXMLParts книги Excel версии 2007 и выше. Данные сохраняются непосредственно в файле книги. С одной стороны, пользователь не имеет прямого доступа ко всем элементам этой коллекции, и как следствие, сохраняемые таким образом данные не подвержены случайной утере или порче, а также не болтаются на виду и не привлекают особого внимания. С другой стороны, их легко контролировать, достаточно просто открыть файл .xlsx как архив, и зайти в одноименную папку. Речь, конечно, не идет о хранении конфиденциальной информации, но, например, для сохранения определенных настроек (путей к папкам или сетевым ресурсам, значений контролов пользовательской формы перед закрытием, в конце концов, JS кода для выполнения в htmlfile контейнере) вполне сгодится. Максимальный объем не тестировал, предположительно, речь порядка о сотне мегабайт. Бинарные данные следует предварительно конвертировать в base64 или т. п. Данные относительно неплохо сжимаются zip'ом.

Взаимодействие с сохраняемыми данными реализовано подобно обычному словарю Scripting.Dictionary:
AddItem - добавление записи ключ - значение, если такой ключ уже есть - запись удаляется и создается заново;
AddItems - добавление множества записей ключ - значение, передаваемых в словаре;
GetItem - получения значения по заданному ключу;
GetItems - получение всех записей в виде словаря;
ItemExists - проверка наличия записи с заданным ключом;
RemoveItem - удаление записи с заданным ключом;
RemoveCXStorage - полное удаление из коллекции CustomXMLParts элемента CustomXMLPart, используемого для хранения данных.

Приведенный ниже код следует сохранить в отдельный модуль CXStorage:

Option Explicit

Private Function GetItemsNode()
    
    With ThisWorkbook.CustomXMLParts.SelectByNamespace("CXStorage")
        If .Count = 0 Then ThisWorkbook.CustomXMLParts.Add "<cxs:root xmlns:cxs='CXStorage'><items/></cxs:root>"
        Set GetItemsNode = .Item(1).DocumentElement.FirstChild
    End With
    
End Function

Sub AddItem(sName, sValue)
    
    With GetItemsNode()
        With .SelectNodes("//item[@name='" & sName & "']")
            If .Count > 0 Then .Item(1).Delete
        End With
        .AppendChildNode "item", , msoCustomXMLNodeElement
        With .LastChild
            .AppendChildNode "name", , msoCustomXMLNodeAttribute, sName
            .AppendChildNode , , msoCustomXMLNodeText, sValue
        End With
    End With
    
End Sub

Sub AddItems(cItems)
    
    Dim sName
    
    With GetItemsNode()
        For Each sName In cItems
            With .SelectNodes("//item[@name='" & sName & "']")
                If .Count > 0 Then .Item(1).Delete
            End With
            .AppendChildNode "item", , msoCustomXMLNodeElement
            With .LastChild
                .AppendChildNode "name", , msoCustomXMLNodeAttribute, sName
                .AppendChildNode , , msoCustomXMLNodeText, cItems(sName)
            End With
        Next
    End With
    
End Sub

Function ItemExists(sName)
    
    ItemExists = Not (GetItemsNode().SelectSingleNode("//item[@name='" & sName & "']") Is Nothing)
    
End Function

Function GetItem(sName)
    
    With GetItemsNode().SelectNodes("//item[@name='" & sName & "']")
        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


Function GetItems()
    
    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
    
End Function

Sub RemoveItem(sName)
    
    With GetItemsNode().SelectNodes("//item[@name='" & sName & "']")
        If .Count > 0 Then .Item(1).Delete
    End With
    
End Sub

Sub RemoveCXStorage()
    
    Dim oPart
    
    For Each oPart In ThisWorkbook.CustomXMLParts.SelectByNamespace("CXStorage")
        oPart.Delete
    Next
    
End Sub

И простейший код для тестирования в другом модуле:

Option Explicit

Sub Test1()
    
    Dim sKey
    
    RemoveCXStorage
    
    CXStorage.AddItem "MyItem", "MyValue"
    CXStorage.AddItem "MyXml", "<node>text</node>"
    CXStorage.AddItem "MyText", "Line #1" & vbCrLf & "Line #2" & vbCrLf & "Line #3"
    CXStorage.AddItem Empty, "Empty"
    
    With CXStorage.GetItems()
        For Each sKey In .Keys()
            MsgBox sKey & vbCrLf & .Item(sKey)
        Next
    End With
    
    
End Sub

Sub Test2()
    
    With CreateObject("Scripting.Dictionary")
        Do
            .Item(.Count) = Mid(CreateObject("Scriptlet.TypeLib").GUID, 1, 38)
        Loop Until .Count = 100000
        CXStorage.AddItem "CapacityTest", Join(.Items())
    End With
    MsgBox Len(CXStorage.GetItem("CapacityTest"))
    
End Sub

Если кому лень копипастить код - прикрепляю готовую книгу.

Post's attachments

CXStorage_Module_customxmlparts_storage.xlsm 19.75 kb, 4 downloads since 2019-01-18 

You don't have the permssions to download the attachments of this post.
Щт Уккщк Куыгьу Туче
’ҐЄгй п Є®¤®ў п бва Ёж : 1251

2

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

omegastripes пишет:

кодом, позволяющим хранить произвольные текстовые данные в коллекции CustomXMLParts книги Excel версии 2007 и выше. Данные сохраняются непосредственно в файле книги. С одной стороны, пользователь не имеет прямого доступа ко всем элементам этой коллекции, и как следствие, сохраняемые таким образом данные не подвержены случайной утере или порче, а также не болтаются на виду и не привлекают особого внимания. С другой стороны, их легко контролировать, достаточно просто открыть файл .xlsx как архив, и зайти в одноименную папку.

Есть вариант попроще, например:

ActiveWorkbook.Worksheets.Item("Лист2").Visible = xlVeryHidden

Работает и в версиях до 2007.

3

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

alexii пишет:

Есть вариант попроще, например:

ActiveWorkbook.Worksheets.Item("Лист2").Visible = xlVeryHidden

Работает и в версиях до 2007.

Метод с xlVeryHidden листом имеет пару недостатков по сравнению с CustomXMLParts.
1. Размер данных, которые можно поместить в одну ячейку, ограничен 32 КБ, для больших объемов придется изощраться с разбивкой и склейкой. В моем случае, ограничение около 100 МБ.
2. Нередко при генерации каких-либо отчетов в Excel, макрос начинается с создания листа и удаления всех остальных в цикле. Лист с данными может быть случайно удален вместе с остальными "до кучи". Иными словами, риск потерять данные выше.

Щт Уккщк Куыгьу Туче
’ҐЄгй п Є®¤®ў п бва Ёж : 1251

4

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

Да и вообще можно просто Shift-Del на файле нажать .

5 (изменено: mikegti@yandex.ru, 2021-10-20 17:52:26)

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

class code - insert in Class Module

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

test code - insert in Module


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