从旧文档运行时错误VBA，XML

时间：2018-03-20 13:43:16

标签： xml vba

我想在一个xml文档中将第四个“模型”节点（具有“有限公司”的节点）作为客户，并将其（完整地）移动到新的空xml文档。我已经看到了一些关于在VB和Java中做这种事情的线程，但它们对我想要做的事情并没有太大的帮助（并且它们都没有使用VBA）。然而，他们确实做了类似我最后两行代码的事情，但我不能在最后一行中遇到错误。如何将此节点附加到新文档？我敢肯定我可能会遗漏一些非常愚蠢的东西。它是什么？我使用importNode错了吗？

我的xmls。 FILENAME1：

<?xml version="1.0" encoding="utf-8"?>
<MyFile xmlns="urn:MyFile-schema">
    <Files>New</Files>
    <Source>Imported</Source>
    <Destination>Kia</Destination>
    <Auto>Sofia </Auto>
    <User>MMOUSE</User>
    <TimeStamp>2017-11-13T10:00:00</TimeStamp>
    <Model Source="Yes">
        <Customer>Jeff Mills</Customer>
        <CustomerCategory>Individual</CustomerCategory>
        <Vehicle>
            <VehicleName>Liona</VehicleName>
            <Door>
                <DoorColor>Brown</DoorColor>
            </Door>
            <Door>
                <DoorColor>Black</DoorColor>
            </Door>
        </Vehicle>
    </Model>
    <Model Source="Yes">
        <Customer>Jen Mills</Customer>
        <CustomerCategory>Individual</CustomerCategory>
        <Vehicle>
            <VehicleName>Cleo</VehicleName>
            <Door>
                <DoorColor>Brown</DoorColor>
            </Door>
            <Door>
                <DoorColor>Black</DoorColor>
            </Door>
        </Vehicle>
    </Model>
    <Model Source="Yes">
        <Customer>Dan Blackburn</Customer>
        <CustomerCategory>Individual</CustomerCategory>
        <Vehicle>
            <VehicleName>Christina</VehicleName>
            <Door>
                <DoorColor>Brown</DoorColor>
            </Door>
            <Door>
                <DoorColor>Black</DoorColor>
            </Door>
        </Vehicle>
    </Model>
    <Model Source="Yes">
        <Customer>Limited Company</Customer>
        <CustomerCategory>Corp</CustomerCategory>
        <Vehicle>
            <VehicleName>Jasmine</VehicleName>
            <Door>
                <DoorColor>red</DoorColor>
            </Door>
            <Door>
                <DoorColor>red</DoorColor>
            </Door>
        </Vehicle>
    </Model>
</MyFile>

文件名2：

<?xml version="1.0" encoding="utf-8"?>
<MyFile xmlns="urn:MyFile-schema">
    <Files>New</Files>
    <Source>Imported</Source>
    <Destination>Kia</Destination>
    <Auto>Sofia </Auto>
    <User>MMOUSE</User>
    <TimeStamp>2017-11-13T10:00:00</TimeStamp>
</MyFile>

我希望fileName2在添加后看起来像这样：

<?xml version="1.0" encoding="utf-8"?>
<MyFile xmlns="urn:MyFile-schema">
    <Files>New</Files>
    <Source>Imported</Source>
    <Destination>Kia</Destination>
    <Auto>Sofia </Auto>
    <User>MMOUSE</User>
    <TimeStamp>2017-11-13T10:00:00</TimeStamp>
    <Model Source="Yes">
        <Customer>Limited Company</Customer>
        <CustomerCategory>Corp</CustomerCategory>
        <Vehicle>
            <VehicleName>Jasmine</VehicleName>
            <Door>
                <DoorColor>red</DoorColor>
            </Door>
            <Door>
                <DoorColor>red</DoorColor>
            </Door>
        </Vehicle>
    </Model>
</MyFile>

我的代码一直在最后一行抛出错误

  

“运行时错误'438'：对象不支持此属性或方法”

这就是我所拥有的：

Option Explicit
Sub MoveNode()

  'Declare Objects
  Dim oldDoc As MSXML2.DOMDocument60                'Object for the oldDoc
  Dim newDoc As MSXML2.DOMDocument60            'Object for the newDoc
  Dim newNode As IXMLDOMNode                    'for the new node

  'Initialize objects and Variables
  Set oldDoc = New MSXML2.DOMDocument60
  Set newDoc = New MSXML2.DOMDocument60
  oldDoc.validateOnParse = False
  newDoc.validateOnParse = False

  ‘some code to get filename and path from user and store as fileName1 and fileName2

  'Load the docs
  oldDoc.Load fileName1
  oldDoc.setProperty "SelectionNamespaces", "xmlns:prefix='urn:MyFile-schema'"

  newDoc.Load fileName2
  newDoc.setProperty "SelectionNamespaces", "xmlns:prefix='urn:MyFile-schema'"


  Set newNode = newDoc.importNode(oldDoc.SelectSingleNode("//prefix:Model[4]"), True)
  newDoc.SelectSingleNode("//prefix:MyFile").appendChild (newNode)
End Sub

2 个答案:

答案 0 :(得分：1)

由于@MathieuGuindon在括号中确定了包装参数的主要问题，您可以简单地删除或分配给另一个对象：

newDoc.SelectSingleNode("//prefix:MyFile").appendChild xNode

或者，将其指定为函数

Dim var As Variant

Set var = newDoc.SelectSingleNode("//prefix:MyFile").appendChild(xNode)

考虑以下最佳做法调整：

  1. 包含错误处理，甚至可以提升MSXML文档的parseError。
  2. 修改您的客户搜索更直接的搜索受限公司而不是节点索引[4]，以防第一个XML可以更改排序。< / LI>
  3. 包含.Save以将修改后的 newDoc 输出到文件。
  4. 初始化所有变量，包括 xNode ，并可能更改变量名称以将操作标识为 newDoc ，而 oldDoc 可能会误导，因为您实际上正在添加。
  5. 请务必在结束时释放set个对象，并可能为用户提供成功消息。

    6. <强> VBA 

    Sub MoveNode()
On Error GoTo ErrHandle
    'Declare Objects
    Dim srcfilename As String, addfilename As String, outputfilename As String
    Dim srcDoc As MSXML2.DOMDocument60, addDoc As MSXML2.DOMDocument60           
    Dim xNode As IXMLDOMNode, newNode As IXMLDOMNode

    'Initialize objects and Variables
    Set srcDoc = New MSXML2.DOMDocument60
    Set addDoc = New MSXML2.DOMDocument60
    srcDoc.validateOnParse = False
    addDoc.validateOnParse = False

    'some code to get filenames from user
    srcfilename = "C:\Path\To\Source.xml"
    addfilename = "C:\Path\To\Add_Info.xml"
    outputfilename = "C:\Path\To\Output.xml"

    'Load the docs
    srcDoc.Load srcfilename
    srcDoc.setProperty "SelectionNamespaces", "xmlns:prefix='urn:MyFile-schema'"

    addDoc.Load addfilename
    addDoc.setProperty "SelectionNamespaces", "xmlns:prefix='urn:MyFile-schema'"

    'Parse docs
    Set xNode = srcDoc.importNode(addDoc.SelectSingleNode("//prefix:Model[prefix:Customer='Limited Company']"), True)
    srcDoc.SelectSingleNode("//prefix:MyFile").appendChild xNode

    srcDoc.Save outpfilename
    MsgBox "Successfully added node to original XML!", vbInformation
    GoTo ExitHandle

ExitHandle:
    Set srcDoc = Nothing: Set addDoc = Nothing: Set xNode = Nothing: Set newNode = Nothing
    Exit Sub

ErrHandle:
    MsgBox Err.Number & " - " & Err.Description, vbCritical
    Err.Raise srcDoc.parseError.ErrorCode, , srcDoc.parseError.reason
    Resume ExitHandle
End Sub

答案 1 :(得分：1)

因为我会放弃这个机会，所以还要考虑XSLT，这是一种用于操作XML文件的转换语言。 MSXML库可以运行XSLT 1.0脚本，XSLT维护document()函数，因此可以解析XML文件。务必将源和添加信息文档放在同一文件夹中。

XSLT （另存为.xsl文件，一个特殊的.xml文件） 

<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
                              xmlns:doc="urn:MyFile-schema" >
  <xsl:output indent="yes"/>
  <xsl:strip-space elements="*"/>

  <xsl:template match="@*|node()">
    <xsl:copy>
      <xsl:apply-templates select="@*|node()"/>
    </xsl:copy>
  </xsl:template>

  <xsl:template match="doc:MyFile">
    <xsl:copy>
        <xsl:apply-templates />
        <xsl:copy-of select="document('Add_Info.xml')/doc:MyFile
                             /doc:Model[doc:Customer='Limited Company']" />
    </xsl:copy>
  </xsl:template>

</xsl:stylesheet>

<强> VBA 

Sub XSLTransform()
On Error GoTo ErrHandle
    Dim xmldoc As New MSXML2.DOMDocument, xslDoc As New MSXML2.DOMDocument, newDoc As New MSXML2.DOMDocument

    ' LOAD XML AND XSL FILES
    xmlDoc.async = False
    xmldoc.Load "C:\Path\To\Source.xml"

    xslDoc.async = False
    xslDoc.Load "C:\Path\To\XSLT_Script.xsl"

    ' TRANSFORM XML
    xmldoc.transformNodeToObject xslDoc, newDoc
    newDoc.Save "C:\Path\To\Output.xml"

    MsgBox "Successfully transformed XML!", vbInformation
    GoTo ExitHandle

ExitHandle:
    Set xmldoc = Nothing: Set xslDoc = Nothing: Set newDoc = Nothing
    Exit Sub

ErrHandle:
    MsgBox Err.Number & " - " & Err.Description, vbCritical
    Err.Raise xslDoc.parseError.ErrorCode, , xslDoc.parseError.reason
    Resume ExitHandle

End Sub

XSLT的美妙之处在于它是可移植的，不需要MSXML来运行它。因此，即使是Java或Python或PHP也可以运行它来呈现相同的输出！您还可以在同一个脚本中运行其他操作，例如添加其他节点，更改节点名称，文本值等。

相关问题
最新问题