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, 2 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 на файле нажать .