如何在vba中用xml dom 克隆复制节点?

比如有一段xml语句如下:

<bookstore>
<book category="COOKING">
  <title lang="en">Everyday Italian</title> 
  <author>Giada De Laurentiis</author> 
  <year>2005</year> 
  <price>30.00</price> 
</book>
<book category="CHILDREN">
  <title lang="en">Harry Potter</title> 
  <author>J K. Rowling</author> 
  <year>2005</year> 
  <price>29.99</price> 
</book>
<book category="WEB">
  <title lang="en">Learning XML</title> 
  <author>Erik T. Ray</author> 
  <year>2003</year> 
  <price>39.95</price> 
</book>
</bookstore>

如果要在bookstore节点下再复制克隆一个book节点,可以先用cloneNode方法克隆一个节点,然后在找到该节点的父节点parentNode,最后再父节点下用appendChild方法添加刚才克隆的节点,使它成为最后的子节点。

代码如下,其中test.xml存放了上述的XML语句:

Sub QQ1722187970()
    Const NODE_ELEMENT = 1
    Const NODE_ATTRIBUTE = 2
    Const NODE_TEXT = 3
    Const NODE_COMMENT = 8
    Const NODE_DOCUMENT = 9
    '定义一个变量用于存储文本xml
    Dim sXml As String
    sXml = "<?xml version=""1.0"" encoding=""utf-8""?>" & _
    "<note>" & _
    "<to>George</to>" & _
    "<from>John</from>" & _
    "<heading>Reminder</heading>" & _
    "<body>Don't forget the meeting!</body>" & _
    "</note>"
    '定义一个变量用于存储xml文件
    Dim sPathXml As String
    sPathXml = Excel.ThisWorkbook.Path & "\test.xml"
    '定义一个解析xml的变量对象
    Dim oXml As Object
    Set oXml = VBA.CreateObject("Msxml2.DOMDocument.6.0")
'    Set oXml = VBA.CreateObject("Microsoft.XMLDOM")
    With oXml
        '不异步导入xml源
        .async = False
        '导入xml文件
        .Load (sPathXml)
        '导入xml文本
'        .LoadXML (sXml)
        With .parseError
            If .ErrorCode = 0 Then
                Debug.Print "解析成功"
                '解析成功
                '****************************
                '先找到要克隆的同级的节点
                Set oNode = oXml.getElementsByTagName("book")(0)
                '克隆一个新的节点
                Set oNodeNew = oNode.CloneNode(True)
                '将新的节点添加到最后
                oNode.ParentNode.appendChild (oNodeNew)
                
                '****************************
            Else
                '如果解析错误,输出错误的原因
                Debug.Print .reason
            End If
        End With
        '定义一个存储最终xml的文件路径
        Dim sResultXml As String
        sResultXml = Excel.ThisWorkbook.Path & "\result.xml"
        '将解析修改后的xml存盘
        .Save sResultXml
    End With
End Sub
       

发表评论