Хранение данных vba excel

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, 5 downloads since 2019-01-18 

You don’t have the permssions to download the attachments of this post.

omegastripes пишет:

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

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

alexii пишет:

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

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

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

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

Требуется хранить где-нибудь в проекте VBA текстовые массивы (список ПЭВМ, перечень текстовых фильтров и т.д.)

Всегда хранил такие массивы непосредственно в коде программ. Вот захотелось усовершенствовать это дело.
Думаю использовать для таких исходных данных отдельный модуль (Mod_Info), чтобы при изменении этих данных уже прямо «идти» в него и только в нем править.

Возможно, имеет смысл сделать некоторый конфигуратор таких массивов, например, с помощью дополнительной формы?
Какие могут быть ещё варианты хранения массивов в проекте VBA?

Aent, спасибо за советы

большие текстовые массивы как строки комментариев в одноимённых с массивом модулях

Массивы небольшие по 10-20 элементов, всего штук 5-6 массивов.
Они меняются нечасто, но при изменении желательно идти в одно место, если в коде VBA.
Наверно мне незачем их писать в комментарии, просто явным присвоением наверно введу.

Вариант — внедрённый в офисный документ ini (xml) файл.

Про него я думал, но я умею только отдельный, лежащий неподалеку на диске.
Ведь оперативность изменений — мгновенная и гибкая.

Отсюда вопросы:
1. Есть ли какой стандартый (классический) формат у таких ini/xml-файлов, чтобы хранить текстовые массивы?
2. Внедрять в офисный документ, это как?

&quot писал(а):
1. Есть ли какой стандартый (классический) формат у таких ini/xml-файлов, чтобы хранить текстовые массивы?
2. Внедрять в офисный документ, это как?

1. Нет
2. Я имел в виду ведрение через OleObjects. Но для небольших массивов это не имеет смысла.
А почему бы вам не хранить данные в самом офисном документе ?
В листе Excel или в переменных (Variables) Word.
Можно так же использовать пользовательские Property документа.

Принял для себя решение хранить в отдельном ini-файле, формат его придумаю, выложу на обсуждение…
Потому что удобнее и оперативнее изменять исходные данные и не надо будет сохранять сам проект.
Можно будет скомпилировать потом форму при желании в самостоятельный EXE-шник.

А почему бы вам не хранить данные в самом офисном документе ?
В листе Excel или в переменных (Variables) Word.

Я делаю форму для другого приложения с VBA, а там подходящих объектов нет и они не удобны

хранить в отдельном ini-файле, формат его придумаю, выложу на обсуждение…

# это комментарий - удобно выводить из работы но не удалять значения
[Nodes]
Node_01
Node_02
Node_03
#Node_04
Node_05
Node_06
[Nodes_End]
[Filters]
расчет
задание
ввод
ошибка
тревога
график
[Filters_End]
[Users]
Gosha
Misha
Lena
Vanja
[Users_End]
....