xmlObj.cls

Option Explicit

Dim xmlObj      As Object
Dim xmlAttr     As Object
Dim xmlNode     As Object
Dim xmlString   As String

Private Sub Class_Initialize()

    Set xmlObj = CreateObject("MSXML2.DOMDocument")
    xmlObj.async = False
    xmlObj.setProperty "SelectionLanguage", "XPath"
    
    xmlObj.appendChild xmlObj.createProcessingInstruction("xml", "version='1.0' encoding='UTF-8'")
End Sub

Private Sub Class_Terminate()
    Set xmlObj = Nothing
End Sub

Public Sub XMLin(ByVal data As Variant)
    
    If TypeName(data) = "String" Then
        Call FileLoad(data)
        
    ElseIf TypeName(data) = "Dictionary" Then
        Call judgeTypeName(data)
        
    Else
        Call Die("XMLinメソッドは、String型またはDictionary型のみを取ることができます" & vbCrLf & _
                 "引数の型：" & TypeName(data))
    End If
    
End Sub

Public Sub XMLout(ByVal FilePath As String)
    xmlObj.Save FilePath
End Sub

Public Function XPath(ByVal strXPath As String)
    
    'xmlの文字列をロードする
    xmlObj.loadXML xmlString
    
    Set XPath = xmlObj.documentElement.selectNodes(strXPath)
    
End Function


Private Sub FileLoad(ByVal FilePath As Variant)
    
    Dim FH  As Object
    Dim FSO As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    xmlString = ""
    
    If Not FSO.FileExists(FilePath) Then Call Die("FileLoadメソッド：ファイルは存在しません" & vbCrLf & "FilePath:" & FilePath)
    
    Set FH = FSO.OPenTextFile(FilePath, 1)
    
    Do While Not FH.AtEndOfStream
        xmlString = xmlString & FH.ReadLine
    
    Loop
    
    FH.Close
    
    Set FH = Nothing
    Set FSO = Nothing
    
End Sub

Private Sub judgeTypeName(ByRef data As Variant)
    
    Dim counter As Long
    Dim key     As Variant
    
    'キーに属性を含んでいる場合を高所して先に属性の登録を行う
    Call AddAttributeNode(data)
    
    
    For Each key In data
        counter = counter + 1
        
        If AddXmlNode(key) Then GoTo NextForLoop

        
        If TypeName(key) = "Dictionary" Then
            Call judgeTypeName(key)
            If counter = data.Count Then _
                Set xmlNode = xmlNode.parentNode
            
        ElseIf TypeName(data(key)) = "Collection" Then
            Call judgeTypeName(data(key))
                
        ElseIf TypeName(data(key)) = "Dictionary" Then
            Call judgeTypeName(data(key))
            
            If counter = data.Count Then _
                Set xmlNode = xmlNode.parentNode
            
        ElseIf TypeName(data(key)) = "String" Then
            Call AddChildText(data(key))
        
        Else
            Call Die("judgeTypeNameメソッドエラー：")
            Debug.Print ""
        
        End If
        
NextForLoop:
    Next
    
End Sub

Private Sub AddChildText(ByVal ChildText As String)
    '子要素にテキストを追加
    Set xmlNode = xmlNode.appendChild(xmlObj.createTextNode(ChildText))
    Set xmlNode = xmlNode.parentNode
    Set xmlNode = xmlNode.parentNode
    
End Sub


Private Sub AddAttributeNode(ByRef data As Variant)
    
    Dim key As Variant
    
    '子要素をぶら下げた後に属性処理をすると意図したところと違うところに属性がつくので
    '最初にキーを走査して属性を探しあれば親要素に属性を追加する
    For Each key In data
    
        If TypeName(key) <> "String" Then GoTo NextForEach
        If key = "@" Then
            Call Die("AddAttributeNodeメソッドエラー：属性名がありません")
            
        ElseIf Left(key, 1) = "@" Then
            Set xmlAttr = xmlNode.Attributes.setNamedItem(xmlObj.createAttribute(Mid(key, 2, Len(key))))
            xmlAttr.nodeValue = data(key)
        End If

NextForEach:
    Next
    
End Sub

Private Function AddXmlNode(ByRef key As Variant)
    
    If TypeName(key) <> "String" Then
        Exit Function
    
    ElseIf key = "" Then
        Exit Function
    
    End If
    
    
    'キーを処理する
    If xmlNode Is Nothing Then
    'Nothingの時は初なのでルートとして指定
        Set xmlNode = xmlObj.appendChild(xmlObj.CreateElement(key))
    
    Else
    '親要素以外の処理
        If Left(key, 1) <> "@" Then
        '@で始まらない時は、子要素として登録。 False(0)を返す
            Set xmlNode = xmlNode.appendChild(xmlObj.CreateElement(key))
            AddXmlNode = 0
            
       Else
       '@で始まる時は、True(1)を返す
            AddXmlNode = 1
       
       End If
       
    End If
    
End Function

Private Sub Die(ByVal msg As String)
    MsgBox "下記理由により終了します" & vbCrLf & _
           msg
    End
End Sub