Option Explicit

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'  I wish to use an XML data structure of the form to replace the use of Custom Document Properties
'  and to remove the need for multiple other related variables for various bits of Ribbon Controls
'
' <root xmlns=myNamespace>
'   <property id="uniquename1">
'       <Value1>Value1</value1>  'each value is an element
'       <value2>Value2</value2>
'       <value3>Value3</value2>
'   <property id="uniquename2">
'       <Value1>Value1</value1>
'       <value2>Value2</value2>
'       <value3>Value3</value2>'
'   <property id="uniquename3">
'       <Value1>Value1</value1>
'       <value2>Value2</value2>
'       <value3>Value3</value2>'
'    </property>
'</Root>
'
' Whilst Word's CustomXMLParts will create the above it also insists on inserting namespace prefixes e.g.
' The output from the complete testing suite is provided below.
'
'<?xml version="1.0"?>
'<arcRoot xmlns="MyUserNS">                         ' This namespace is my addition
'   <arcProp ns0:ID="myProp1" xmlns:ns0="myUserNS"> ' The prefix here has been 'kindly' inserted by CustomXMLParts
'       <Checked>False</Checked>
'       <Enabled>True</Enabled>
'       <Value>True</Value>
'   </arcProp>
'   <arcProp ns0:ID="myProp6" xmlns:ns0="myUserNS">
'       <Visibility>True</Visibility>
'       <Checked>False</Checked>
'       <Enabled>True</Enabled>
'   </arcProp>
'   <arcProp ns0:ID="myProp7" xmlns:ns0="MyUserNS">
'       <Value>True</Value>
'       <Visibility>True</Visibility>
'       <Checked>False</Checked>
'       <Enabled>True</Enabled>
'   </arcProp>
'   <arcProp ns0:ID="myProp8" xmlns:ns0="MyUserNS">
'       <Visibility>True</Visibility>
'       <Checked>False</Checked>
'       <Enabled>True</Enabled>
'       <Value>True</Value>
'   </arcProp>
'   <arcProp ns0:ID="myProp9" xmlns:ns0="MyUserNS">
'       <Visibility>True</Visibility>
'       <Checked>False</Checked>
'       <Enabled>True</Enabled>
'       <Value>True</Value>
'   </arcProp>
'</arcRoot>

' This XML allows me to consolidate to the same string for use as a dictionary key, ribbon control ID,
' and replace the custom document property I was previously using.
'
' 1.  Values that need to be persistent across editing sessions
' 2.  Associate ribbon controls with a persistent value if needed
' 3.  Exactly replicate the structure of a dictionary of dictionaries
'
'  Whilst reading and writing the XML may be slow compared to changing values in a scripting.dictionary
'  because the use is relatively infrequent it may be an acceptable overhead and consequently
'  it may be now possible to also eliminate the planned dictionary of dictionaries.


Const arcNS                         As String = "MyUserNS"
Const varID                         As String = "<varID>"
Const varPrefix                     As String = "<varPrefix>"

' Xpaths
' These constants contain markers of the form <varXXXX>
' At the point of use <varXXX> will be replaced by the VBA replace function
' e.g.  myXPath = replace(arcProperty,"<varID>","Identifier")

Const arcRootXPath                  As String = "//<varPrefix>arcRoot"
Const arcPropertyXPath              As String = "//<varPrefix>arcProp[@<varPrefix>ID=""<varID>""]"
Const arcNSRootXML                  As String = "<arcRoot xmlns=""MyUserNS""></arcRoot>"
Const arcProperty                   As String = "arcProp"

Private arcXMLPart                  As CustomXMLPart
Private arcPrefix                   As String

Private Sub Class_Initialize()

 Dim myPrefixMapping                As CustomXMLPrefixMappings
 Dim myPart                         As CustomXMLPart
 
    With ActiveDocument
        For Each myPart In .CustomXMLParts
            If myPart.NamespaceURI = arcNS Then
                Set arcXMLPart = .CustomXMLParts(arcNS)
                ' sbInstantiatePropertyAndRibbonControls
                Exit For
            End If
        Next
        If arcXMLPart Is Nothing Then
            .CustomXMLParts.Add XML:=arcNSRootXML
            Set arcXMLPart = .CustomXMLParts(arcNS)
        End If
        
        Set myPrefixMapping = .CustomXMLParts(arcNS).NamespaceManager
        ' Despite the fact that we have not set a prefix for our namespace, CustomXMLParts 'helpfully' adds a prefix statement to each
        ' xml statement that we add.  Therefore we need to preserve the prefix to do anything useful
        arcPrefix = myPrefixMapping.Item(1).Prefix & ":"
    End With
    
End Sub

Private Function fnNodeXpath(Property As String, Optional Child As String = vbNullString) As String

Dim myNodeXPath As String

    myNodeXPath = Replace(arcPropertyXPath, varID, Property)
    myNodeXPath = Replace(myNodeXPath, varPrefix, arcPrefix)
    If Not Child = vbNullString Then
        myNodeXPath = myNodeXPath & "/" & arcPrefix & Child
    End If
    fnNodeXpath = myNodeXPath
    
End Function


Public Function Exists(Property As String, Optional Child As String = vbNullString) As Boolean

    If arcXMLPart.SelectSingleNode(fnNodeXpath(Property:=Property, Child:=Child)) Is Nothing Then
        Exists = False
    Else
        Exists = True
    End If
End Function

Public Function Count(Optional Property As String = vbNullString) As Long
    Dim myNodes                     As CustomXMLNodes
    
    If Property = vbNullString Then
        Set myNodes = arcXMLPart.SelectNodes("//ns0:arcRoot/ns0:arcProp")
        Count = myNodes.Count

    Else
        Set myNodes = arcXMLPart.SelectNodes(fnNodeXpath(Property:=Property)).Item(1).ChildNodes
        Count = myNodes.Count
    End If
    

End Function

Public Function Properties() As Variant

' Returns a variant array containing strings representing the ID attribute for each property
' This allows easy iteration over the collection of properties as per the test demonstration

Dim myProperties                        As Long
Dim myIndex                             As Long
Dim myArray()                           As Variant
Dim myPropertyXPath                     As String

    myProperties = Count()
    ReDim myArray(myProperties)
    For myIndex = 1 To myProperties
        myPropertyXPath = arcRootXPath & "/" & arcPrefix & arcProperty & "[" & CStr(myIndex) & "]"
        myPropertyXPath = Replace(myPropertyXPath, varPrefix, arcPrefix)
        myArray(myIndex) = arcXMLPart.SelectSingleNode(myPropertyXPath).Attributes(1).Text
    Next
        
    Properties = myArray
End Function


Public Function AddProperty(NodeID As String) As Boolean

Const myPropertyIDTag               As String = "ID"

Dim myParentNode                    As CustomXMLNode
Dim myprefix                        As String

    If Exists(Property:=NodeID) Then
        Debug.Print "clsMyUserXMLManager.addProperty: Property already exists - identifier->" & NodeID
        AddProperty = False
    Else
        With arcXMLPart
            Set myParentNode = .SelectSingleNode(Replace(arcRootXPath, varPrefix, arcPrefix))
            .AddNode Parent:=myParentNode, Name:=arcProperty, NamespaceURI:=arcNS
            .AddNode Parent:=myParentNode.LastChild, Name:=myPropertyIDTag, NamespaceURI:=arcNS, NodeType:=msoCustomXMLNodeAttribute, NodeValue:=NodeID
            AddProperty = True
        End With
   End If
End Function

Public Function AddElement(NodeID As String, Name As String, Value As String) As Boolean

Dim myNodeXPath                     As String
Dim myParentNode                    As CustomXMLNode

    ' Trap the case where the property does not exists
    If Not Exists(Property:=NodeID) Then
        Debug.Print "clsMyUserXMLManager.addElement: Node for Element does not exist - property/element->" & NodeID & "/" & Name
        AddElement = False
        Exit Function
    End If
        
    ' The property exists so now trap the case where the element already exists
    If Exists(Property:=NodeID, Child:=Name) Then
        Debug.Print "clsMyUserXMLManager.addElement: Element already exists - property/element->" & NodeID & "/" & Name
        AddElement = False
    Exit Function
    End If
        
    ' The node exists but the element doesn't so add the new element
    Set myParentNode = arcXMLPart.SelectSingleNode(fnNodeXpath(Property:=NodeID))
    arcXMLPart.AddNode Parent:=myParentNode, Name:=Name, NodeValue:=Value, NamespaceURI:=arcNS, NodeType:=msoCustomXMLNodeElement
    AddElement = True
End Function

Public Property Let Value(Property As String, Child As String, Value As Variant)

Dim myNodeXPath                  As String
Dim myXMLValue                  As String

    If Not Exists(Property:=Property, Child:=Child) Then
        Debug.Print "clsMyUserXMLManager.Value: Node does not exists - identifier/child->" & Property & "/" & Child
        Exit Property
    End If
        
    myXMLValue = TypeName(Value) & "," & CStr(Value)
    ActiveDocument.CustomXMLParts(arcNS).SelectSingleNode(fnNodeXpath(Property:=Property, Child:=Child)).Text = myXMLValue
    
End Property


Public Property Get Value(Property As String, Child As String) As Variant

Dim myXMLValue                  As String
Dim myType                      As String
Dim myValue                     As String

    If Not Exists(Property:=Property, Child:=Child) Then
        Value = vbEmpty
        Exit Property
    End If
    
    myXMLValue = ActiveDocument.CustomXMLParts(arcNS).SelectSingleNode(fnNodeXpath(Property:=Property, Child:=Child)).Text
    myType = Split(myXMLValue, ",")(0)
    myValue = Split(myXMLValue, ",")(1)
    
    Select Case myType
        Case "Boolean":             Value = CBool(myValue)
        Case "Integer", "Long":     Value = CLng(myValue)
        Case "String":              Value = myValue
        Case Else
            Debug.Print "Type not implemented ->" & myType
    End Select
   
End Property


Public Function Delete(Property As String, Optional Child As String = vbNullString) As Boolean

Dim myNodeXPath                 As String

    If Not Exists(Property:=Property, Child:=Child) Then
        Debug.Print "clsMyUserXMLManager.Delete Property does not exist ->" & Property
        Delete = False
        Exit Function
    End If
    
    arcXMLPart.SelectSingleNode(fnNodeXpath(Property:=Property, Child:=Child)).Delete
    Delete = True
End Function

Private sub sbInstantiatePropertyAndRibbonControls()

    ' The next step !!!!!!
        
End Function

Sub testCDPReplacment()

Dim docXML As clsmyUserXMLManager
Dim myValue As Variant
Dim myName As Variant
Dim myPropertyList As Variant

    'DeleteAllCustomXML  'Sorry you'll have to write your own
    
    ' Create the root with namespace
    Set docXML = New clsmyUserXMLManager
  
    
    ' add properties
    docXML.AddProperty NodeID:="myProp1"
    docXML.AddProperty NodeID:="myProp2"
    docXML.AddProperty NodeID:="myProp6"
    docXML.AddProperty NodeID:="myProp7"
    docXML.AddProperty NodeID:="myProp8"
    docXML.AddProperty NodeID:="myProp9"

    
    
    
    ' should produce an exists error
    docXML.AddProperty NodeID:="myProp2"

    ' add elements to properties
    docXML.AddElement NodeID:="myProp1", Name:="Visibility", Value:="True"
    docXML.AddElement NodeID:="myProp1", Name:="Checked", Value:="False"
    docXML.AddElement NodeID:="myProp1", Name:="Enabled", Value:="True"
    docXML.AddElement NodeID:="myProp1", Name:="Value", Value:=True  ' this is boolean
    
    docXML.AddElement NodeID:="myProp6", Name:="Visibility", Value:="True"
    docXML.AddElement NodeID:="myProp6", Name:="Checked", Value:="False"
    docXML.AddElement NodeID:="myProp6", Name:="Enabled", Value:="True"
    
    docXML.AddElement NodeID:="myProp7", Name:="Value", Value:=True  ' this is boolean
    docXML.AddElement NodeID:="myProp7", Name:="Visibility", Value:="True"
    docXML.AddElement NodeID:="myProp7", Name:="Checked", Value:="False"
    docXML.AddElement NodeID:="myProp7", Name:="Enabled", Value:="True"
    
    docXML.AddElement NodeID:="myProp8", Name:="Visibility", Value:="True"
    docXML.AddElement NodeID:="myProp8", Name:="Checked", Value:="False"
    docXML.AddElement NodeID:="myProp8", Name:="Enabled", Value:="True"
    docXML.AddElement NodeID:="myProp8", Name:="Value", Value:=True  ' this is boolean

    docXML.AddElement NodeID:="myProp9", Name:="Visibility", Value:="True"
    docXML.AddElement NodeID:="myProp9", Name:="Checked", Value:="False"
    docXML.AddElement NodeID:="myProp9", Name:="Enabled", Value:="True"
    docXML.AddElement NodeID:="myProp9", Name:="Value", Value:=True  ' this is boolean

    
    ' this should produce an already exists error
    docXML.AddElement NodeID:="myProp1", Name:="Enabled", Value:="True"
    
    ' add element to non existent node
    docXML.AddElement NodeID:="myProp4", Name:="Visibiliy", Value:=123456789

    ' check for existence of properties
    If docXML.Exists("myProp1") Then
        Debug.Print "Property myProp1 found true = true"
    Else
        Debug.Print "Property myProp1 found true = false"
    End If
    
    'check for existnce of element
    If docXML.Exists(Property:="myProp1", Child:="Visibility") Then
        Debug.Print "Element Visibility found true = true"
    Else
        Debug.Print "Element visibility found true = false"
    End If
    
    ' Try changeing values of elements
    docXML.Value(Property:="myProp1", Child:="Visibility") = 32         ' number
    myValue = docXML.Value(Property:="myProp1", Child:="Visibility")
    Debug.Print TypeName(myValue) & " " & myValue
    
    docXML.Value(Property:="myProp1", Child:="Visibility") = True       'boolean
    myValue = docXML.Value(Property:="myProp1", Child:="Visibility")
    Debug.Print TypeName(myValue) & " " & myValue
    
    docXML.Value(Property:="myProp1", Child:="Visibility") = "True"     'string
    myValue = docXML.Value(Property:="myProp1", Child:="Visibility")
    Debug.Print TypeName(myValue) & " " & myValue

    ' delete at element level
    docXML.Delete Property:="myProp1", Child:="Visibility"
    
    If docXML.Exists(Property:="myProp1", Child:="Visibility") Then
        Debug.Print "Deletion failed"
    Else
        Debug.Print "Deletion succeeeded"
    End If
    
    'delete at property level
    docXML.Delete Property:="myProp2"
    
    If docXML.Exists(Property:="myProp2") Then
        Debug.Print "Deletion failed"
    Else
        Debug.Print "Deletion succeeeded"
    End If
    
    Debug.Print "Total properties = " & docXML.Count
    Debug.Print "Total elements in property  = " & docXML.Count(Property:="myProp8")
    
    '  testing that we have correctly retrieved the aray of property IDs
    myPropertyList = docXML.Properties
    For Each myName In myPropertyList
        Debug.Print myName
    Next
    
End Sub