VBA/XML/汎用XMLユーティリティクラスを作る - UCSS_TIPS_AND_SAMPLES

---

汎用的なXMLユーティリティクラスを作成してみる

XMLは便利だけどオブジェクトが沢山あって面倒
なので汎用的なクラスを作ってみる

XMLUtilClass.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "XMLUtilClass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private g_XMLDocument As New DOMDocument50
Private g_currentNode As IXMLDOMNode
Private g_xml_path As String
Private g_xpath_node As String
Private g_xml_selection As IXMLDOMSelection

'attribute のセット
Public Sub setAttributeElement(ele As IXMLDOMElement, name As String, value As String)
    Dim att As MSXML2.IXMLDOMAttribute
    Set att = g_XMLDocument.createAttribute(name)
    att.Text = value
    ele.setAttributeNode att
    Set att = Nothing
End Sub

'attribute のセット
Public Sub setAttributeEx(name As String, value As String)
    Call setAttribute(g_currentNode, name, value)
End Sub
'attribute のセット（旧版）
Private Sub setAttribute_OLD(node As IXMLDOMNode, name As String, value As String)

    'attributeがある場合は上書き
    If node Is Nothing Then Exit Sub
    Dim i As Integer
    Dim n As IXMLDOMNode
    For i = 0 To node.Attributes.Length - 1
        If name = node.Attributes(i).baseName Then
            node.Attributes(i).Text = value
            Exit Sub
        End If
    Next
    '無い場合は作成
    Call addAttribute(node, name, value)

End Sub

'attribute のセット
Public Sub setAttribute(node As IXMLDOMNode, name As String, value As String)
    Dim n As IXMLDOMNode
    'attributeがある場合は上書き
    If node Is Nothing Then Exit Sub
    Set n = node.Attributes.getNamedItem(name)
    If n Is Nothing Then
        '無い場合は作成
        Call addAttribute(node, name, value)
    Else
        n.Text = value
    End If
    Set n = Nothing
End Sub

'attribute の追加
Public Sub addAttribute(node As IXMLDOMNode, name As String, value As String)
            
    If node Is Nothing Then Exit Sub
    Dim att As IXMLDOMNode
    Set att = g_XMLDocument.createAttribute(name)
    att.Text = value
    Dim dmy As Object
    Set dmy = node.Attributes.setNamedItem(att)
    Set att = Nothing
    Set dmy = Nothing

End Sub

'attribute の追加
Public Sub addAttributeEx(name As String, value As String)
    Call addAttribute(g_currentNode, name, value)
End Sub

'attribute の削除
Public Sub removeAttributes(node As IXMLDOMNode, name As String)
    If node Is Nothing Then Exit Sub
    node.Attributes.removeNamedItem (name)
End Sub

'attribute の削除
Public Sub removeAttributesEx(name As String)
    Call removeAttributes(g_currentNode, name)
End Sub

'attribute の数
Public Static Function sizeAttributes(node As IXMLDOMNode) As Long
    sizeAttributes = 0
    If node Is Nothing Then Exit Function
    sizeAttributes = node.Attributes.Length
End Function

'attribute の数
Public Static Function sizeAttributesEx() As Long
    sizeAttributesEx = sizeAttributes(g_currentNode)
End Function

'attribute が存在するか(旧版）
Private Static Function containsKeyAttribute_OLD(node As IXMLDOMNode, name As String) As Boolean
    containsKeyAttribute_OLD = False
    If node Is Nothing Then Exit Function
    Dim i As Integer
    For i = 0 To node.Attributes.Length - 1
        If name = node.Attributes(i).baseName Then
            containsKeyAttribute_OLD = True
            Exit Function
        End If
    Next
End Function

'attribute が存在するか
Public Static Function containsKeyAttribute(node As IXMLDOMNode, name As String) As Boolean
    containsKeyAttribute = False
    If node Is Nothing Then Exit Function
    containsKeyAttribute = (Not node.Attributes.getNamedItem(name) Is Nothing)
End Function

'attribute が存在するか
Public Function containsKeyAttributeEx(name As String) As String
    containsKeyAttributeEx = containsKeyAttribute(g_currentNode, name)
End Function

'attribute のゲット
Public Static Function getAttributeValue(node As IXMLDOMNode, name As String) As String
    Dim n As IXMLDOMNode
    Dim s As String
    If node Is Nothing Then Exit Function
    Set n = node.Attributes.getNamedItem(name)
    If n Is Nothing Then
        s = ""
    Else
        s = n.Text
    End If
    Set n = Nothing
    getAttributeValue = s
End Function

'attribute のゲット（旧版）
Public Static Function getAttributeValue_OLD(node As IXMLDOMNode, name As String) As String
    If node Is Nothing Then Exit Function
    Dim i As Integer
    For i = 0 To node.Attributes.Length - 1
        If name = node.Attributes(i).baseName Then
            getAttributeValue_OLD = node.Attributes(i).Text
            Exit Function
        End If
    Next
End Function


'attribute のゲット
Public Function getAttributeValueEx(name As String) As String
    getAttributeValueEx = getAttributeValue(g_currentNode, name)
End Function

'attributeの値のゲット（名）
Public Function getAttributeNames(node As IXMLDOMNode) As String()
    Dim ret() As String
    If node Is Nothing Then Exit Function
    Dim i As Integer
    For i = 0 To node.Attributes.Length - 1
        ReDim Preserve ret(i)
        ret(i) = node.Attributes(i).baseName
    Next
    getAttributeNames = ret
End Function

'attributeの値のゲット（名）
Public Function getAttributeNamesEx() As String()
    getAttributeNamesEx = getAttributeNames(g_currentNode)
End Function

'attributeの値のゲット（配列）
Public Function getAttributeValues(node As IXMLDOMNode) As String()
    Dim ret() As String
    If node Is Nothing Then Exit Function
    Dim i As Integer
    For i = 0 To node.Attributes.Length - 1
        ReDim Preserve ret(i)
        ret(i) = node.Attributes(i).Text
    Next
    getAttributeValues = ret
End Function

'attributeの値のゲット（配列）
Public Function getAttributeValuesEx() As String()
    getAttributeValuesEx = getAttributeValues(g_currentNode)
End Function

'XMLファイルのロード
Public Sub loadXML(x_xml_path As String)
    g_xml_path = x_xml_path
    Set g_XMLDocument = New DOMDocument50
    g_XMLDocument.async = False
    g_XMLDocument.load (x_xml_path)
    If g_XMLDocument.parsed = False Then
        MsgBox "ファイル形式がXMLでありません。"
    End If
    'カレントノードにセット
    Set g_currentNode = g_XMLDocument
End Sub

'XMLを新規作成する
Public Function createNewXML()
    Dim s As String
    s = "<?xml version=""1.0"" encoding=""UTF-8""?>"
    g_XMLDocument.loadXML s
    'カレントノードにセット
    Set g_currentNode = g_XMLDocument
End Function

'XMLファイルのセーブ
Public Sub save(x_path)
    If IsNull(x_path) = True Or x_path = "" Then
        x_path = g_xml_path
    End If
    g_XMLDocument.save x_path
End Sub

'XMLDocumentからXPathによりノードを取得し、カレントノードに登録する
'状況に応じてgetSelectionNodeと使い分けると便利
Public Function getNode(x_xpath As String) As IXMLDOMNode
    Set g_xml_selection = g_XMLDocument.selectNodes(x_xpath)
    Set g_currentNode = g_xml_selection.NextNode
    Set getNode = g_currentNode
End Function

'カレントノードを取得する
Public Function getCurrentNode() As IXMLDOMNode
    Set getCurrentNode = g_currentNode
End Function

'XMLDocumentからXPathによりセレクションノードを取得し、クラスのメンバにもセットする
'状況に応じてgetNodeと使い分けると便利
'※セレクションに移動したくない場合等に使用
Public Function getSelectionNode(x_xpath As String) As IXMLDOMSelection
    Set g_xml_selection = g_XMLDocument.selectNodes(x_xpath)
    Set getSelectionNode = g_xml_selection
End Function

'セレクションノードをクラスのメンバにセットする
Public Sub setSelectionNode(x_xml_selection As IXMLDOMSelection)
    Set g_xml_selection = x_xml_selection
End Sub

'次のノードを取得し、カレントノードに登録する
Public Function getNextNode() As IXMLDOMNode
    Set g_currentNode = g_xml_selection.NextNode
    Set getNextNode = g_currentNode
End Function

'ノードをカレントノードにセットする
Public Sub setNode(x_node As IXMLDOMNode)
    Set g_currentNode = x_node
End Sub

'カレントノードにエレメントを追加＆移動（子ノードを追加）
Public Function addElement(x_element_name As String)
    Dim xml_element As IXMLDOMElement
    Set xml_element = g_XMLDocument.createElement(x_element_name)
    g_currentNode.appendChild xml_element
    Set g_currentNode = xml_element
    Set xml_element = Nothing
End Function

'カレントノード（エレメント）に値を記述する
Public Function setNodeValue(x_value As String)
    g_currentNode.Text = x_value
End Function

'カレントノード（エレメント）の値を取得する
Public Function getNodeValueEx() As String
    If Not g_currentNode Is Nothing Then
        getNodeValueEx = g_currentNode.Text
    End If
End Function

'カレントノード（エレメント）の値を取得する
Public Function getNodeValue(node As IXMLDOMNode) As String
    If Not node Is Nothing Then
        getNodeValue = node.Text
    End If
End Function

'親ノードを取得＆移動
Public Function getParentNode() As IXMLDOMNode
    Set g_currentNode = g_currentNode.parentNode
    Set getParentNode = g_currentNode
End Function

'カレントノードを削除して親ノードへ移動する
Public Function removeNode()
    If g_currentNode Is Nothing Then
        Exit Function
    End If
    Dim parentNode As IXMLDOMNode
    Set parentNode = g_currentNode.parentNode
    Call parentNode.removeChild(g_currentNode)
    Set g_currentNode = parentNode
    Set parentNode = Nothing
End Function

'子ノードを取得
Public Function getChildNodes() As IXMLDOMNodeList
    If g_currentNode Is Nothing Then
        Exit Function
    End If
    Set getChildNodes = g_currentNode.childNodes
End Function

Public Function getXML() As String
    getXML = g_XMLDocument.xml
End Function

'ターミネイト
Private Sub Class_Terminate()
    Set g_XMLDocument = Nothing
    Set g_currentNode = Nothing
    Set g_xml_selection = Nothing
End Sub

'属性をmapに格納します
Public Function getAttributeMapEx() As XmlCustomMap
    Set getAttributeMapEx = getAttributeMap(g_currentNode)
End Function

'属性をmapに格納します
Public Function getAttributeMap(node As IXMLDOMNode) As XmlCustomMap
    Dim l_att() As String
    Dim l_map As New XmlCustomMap
    Dim i As Integer
    
    If Not node Is Nothing Then
        l_att = getAttributeNames(node)
        For i = 0 To UBound(l_att)
            Call l_map.putValue(l_att(i), getAttributeValue(node, l_att(i)))
        Next
    End If
    
    Set getAttributeMap = l_map

End Function

---

XMLユーティリティクラスのテスト

test1（XMLの作成）

Sub xml_test()
    Dim cls As New XMLUtilClass
    'XML新規作成
    cls.createNewXML
    '要素追加&移動
    Call cls.addElement("testelement1")
    '要素追加&移動
    Call cls.addElement("testelement2")
    '要素の値をセット
    Call cls.setNodeValue("nodevalue1")
    '属性追加
    Call cls.setAttributeEx("testname", "testvalue")
    Call cls.setAttributeEx("testname2", "5")
    '要素親へ移動
    Call cls.getParentNode
    '要素追加&移動
    Call cls.addElement("testelement2")
    '要素の値をセット
    Call cls.setNodeValue("nodevalue2")
    '属性追加
    Call cls.setAttributeEx("testname", "testvalue")
    Call cls.setAttributeEx("testname2", "10")
    'XMLを保存
    cls.save ("C:\temp\test.xml")
    '開放
    Set cls = Nothing
    MsgBox "おわり"
End Sub

結果（test.xml)

<testelement1>
  <testelement2 testname="testvalue" testname2="5">nodevalue1</testelement2>
  <testelement2 testname="testvalue" testname2="10">nodevalue2</testelement2>
</testelement1>

---

test2（属性の全取得）

Sub xml_test2()
    Dim cls As New XMLUtilClass
    Dim n() As String
    Dim v() As String
    Dim i As Integer
    'XMLファイルをロード
    cls.loadXML ("C:\temp\test.xml")
    'XPathからセレクションノードを取得
    cls.getSelectionNode ("testelement1/testelement2")
    '全取得ノード分ループ
    Do While (Not cls.getNextNode() Is Nothing)
        '属性を全て取得
        n = cls.getAttributeNamesEx
        v = cls.getAttributeValuesEx
        For i = 0 To UBound(n)
            Debug.Print n(i) & ":" & v(i)
        Next
    Loop
    Set cls = Nothing
    MsgBox "おわり"
End Sub

結果

testname:testvalue
testname2:5
testname:testvalue
testname2:10

---

test3（属性の一部取得）

Sub xml_test3()
    Dim cls As New XMLUtilClass
    'XMLファイルをロード
    cls.loadXML ("C:\temp\test.xml")
    'XPathからセレクションノードを取得
    cls.getSelectionNode ("//testelement2[number(@testname2)>8 and contains(@testname,'value')]")
    '全取得ノード分ループ
    Do While (Not cls.getNextNode() Is Nothing)
        '属性を取得
        Debug.Print "testname:" & cls.getAttributeValueEx("testname") & " testname2:" & cls.getAttributeValueEx("testname2")
    Loop
    Set cls = Nothing
    MsgBox "おわり"
End Sub

結果

testname:testvalue testname2:10

---

test4（子ノードの取得）

Sub xml_test4_3()
    Dim cls As New XMLUtilClass
    'XMLファイルをロード
    cls.loadXML ("C:\temp\test.xml")
    'XPathからセレクションノードを取得
    cls.getSelectionNode ("testelement1")
    Do While (Not cls.getNextNode() Is Nothing)
        Dim childNodelist As IXMLDOMNodeList
        Dim childNode As IXMLDOMNode
        '子ノードリストを取得
        Set childNodelist = cls.getChildNodes
        '子ノードを全て取得
        For Each childNode In childNodelist
            '属性を取得
            Debug.Print " testname1:" & cls.getAttributeValue(childNode, "testname") & _
                        " testname2:" & cls.getAttributeValue(childNode, "testname2") & _
                        " NodeValue:" & cls.getNodeValue(childNode)
        Next
        Set childNodelist = Nothing
        Set childNode = Nothing
    Loop
    Set cls = Nothing
    MsgBox "おわり"
End Sub

結果

testname1:testvaluetestname2:5 nodevalue1
testname1:testvaluetestname2:10 nodevalue2

---