VBAでXMLパース

XMLパース

Option Explicit

Enum xmlNodeType
eElement = 1
eAttribute = 2
eText = 3
eCdataSection = 4
eEntityReference = 5
eEntity = 6
eProcessingInstruction = 7
eComment = 8
eDocument = 9
eDocumentType = 10
eDocumentFragment = 11
eNotation = 12
End Enum

Const strFilePath As String = "C:\"
Public oXML As Object
Public curRoot
Public curNodes
Public parNodes
Public oo As Long
Public oi As Long
Public oj As Long
Public cntSheet As Integer
Public outSheet As Worksheet

Public Sub xmlParserProcess()
    Dim buff As String
    'DOMドキュメント生成
    Set oXML = CreateObject("MSXML.DOMDocument")
    Set outSheet = Application.ActiveWorkbook.Worksheets("展開1")
    cntSheet = 1
    
    'XMLファイル読み込み
    oXML.Load (Application.ActiveWorkbook.Path & "\BDMV-MP.xml")
    If oXML.parseError.ErrorCode <> 0 Then
      MsgBox "XMLファイルの読み込みに失敗しました。"
      Exit Sub
    End If
    Set curRoot = oXML.DocumentElement
    oj = 0
    oi = 1
    
    buff = curRoot.NodeName
    Call putElement(1, "<" & buff & ">")
    If curRoot.Attributes.Length <> 0 Then
      Call putAttribute(curRoot.Attributes, oi)
    End If
    
    Set parNodes = curRoot.ChildNodes
    Call putNodes(parNodes, oi)
    Call putElement(1, "</" & buff & ">")
End Sub

Private Function putNodes(argNode, curII)
    Dim ii As Long
    Dim jj As Long
    Dim oo As Long
    Dim curCnt As Long
    Dim buff As String
    Dim curNodeName As String
    Dim parNodeName As String
    Dim curNode

    oo = curII
    Set curNode = argNode
    curCnt = curNode.Length
    parNodeName = ""
    For ii = 0 To (curCnt - 1)
        Select Case curNode.Item(ii).NodeType
        Case xmlNodeType.eElement
            curNodeName = curNode.Item(ii).NodeName
            buff = "<" & curNodeName & ">"
    
            Debug.Print "ElementNAME=" & buff & " Length[" & curNode.Item(ii).Attributes.Length & "]"
            If parNodeName = "" Then
                parNodeName = curNode.Item(ii).ParentNode.BaseName
                oo = oo + 1
            Else
                If parNodeName <> curNode.Item(ii).ParentNode.BaseName Then
                    oo = oo + 1
                End If
            End If
            Call putElement(oo, buff)
    
            If curNode.Item(ii).Attributes.Length <> 0 Then
                Call putAttribute(curNode.Item(ii).Attributes, oo)
            End If
            If curNode.Item(ii).ChildNodes.Length <> 0 Then
                Call putNodes(curNode.Item(ii).ChildNodes, oo)
                buff = "</" & curNode.Item(ii).NodeName & ">"
                Call putElement(oo, buff)
            End If
        Case xmlNodeType.eText
            buff = "[" & curNode.Item(ii).XML & "]"
            Debug.Print "TextVALUE=" & buff
            Call putElement(curII + 1, buff)
        Case xmlNodeType.eProcessingInstruction
            Debug.Print "NAME=[" & curNodes.Item(ii).Name & "]"
            Debug.Print "NAME=[" & curNodes.Item(ii).Name _
                & "] VALUE=[" & curNodes.Item(ii).Value & "]"
        Case xmlNodeType.eComment
            Debug.Print "CommentVALUE=[" & curNodes.Item(ii).Value & "]"
        Case Else
            Debug.Print "NodeName=[" & curNodes.Item(ii).NodeName & "] NodeTypeNum=[" & curNodes.Item(ii).NodeType & "]"
        End Select
    Next ii
End Function
Private Function putAttribute(argAttrs, argOO As Long)
    Dim jj As Long
    Dim oo As Long
    Dim buff As String
    Dim curAttrs
    oo = argOO
    Set curAttrs = argAttrs
    For jj = 0 To (curAttrs.Length - 1)
        buff = "[" & curAttrs.Item(jj).Name
        buff = buff & "=" & curAttrs.Item(jj).Text & "]"
        oo = oo + 1
        outSheet.Cells(oo, oj) = buff
    Next jj
End Function
Private Function putElement(aoo As Long, aData As String)
    Call incYoko
    outSheet.Cells(aoo, oj) = aData
End Function
Private Function incYoko()
    oj = oj + 1
    If oj > 256 Then
        oj = 1
        cntSheet = cntSheet + 1
        Set outSheet = Application.ActiveWorkbook.Worksheets("展開" & cntSheet)
    End If
End Function