洗掉XML的根標記，但保留其中的內容

我使用下面的代碼使用戶能夠選擇一個 XML 檔案，然后代碼<metadata>從 XML 中洗掉標記，并用修改后的標記替換它；

Sub Button1_Click()
    Dim fso As Object, ts As Object, doc As Object
    Dim data As Object, filename As String
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    ' select file
    With Application.FileDialog(msoFileDialogFilePicker)
        If .Show <> -1 Then Exit Sub
        filename = .SelectedItems(1)
    End With
    
    ' read file and add top level
    Set doc = CreateObject("MSXML2.DOMDocument.6.0")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.OpentextFile(filename)
    doc.LoadXML Replace(ts.readall, "<metadata>", "<root><metadata>", 1, 1) & "</root>" '<metadata> removed
    ts.Close
    
    ' import data tag only
    Dim s As String
    Set data = doc.getElementsByTagName("data")(0)
    s = data.XML
    ' MsgBox s
    
    Set ts = fso.CreateTextFile(filename, True)
    ts.Write s
    ts.Close
    
    MsgBox s 'works perfectly
End Sub

當我被分配使用這樣的 XML 時，上面的代碼非常適合我 -

但是現在，我有一個不同的 XML 來處理，就像 - （區別：ajson根標簽）

如何洗掉ajson開始和結束標簽，以便獲得我想要的結果？請指導...謝謝！

uj5u.com熱心網友回復：

下面是如何通過 XSLT 轉換來實作。

VBA 中的 XSLT：用于 xls 轉換的 Excel VBA 編碼

輸入 XML

<?xml version="1.0"?>
<ajson:json xmlns:ajson="http://www.google.com">
    <metadata>
        <sample>Hi</sample>
    </metadata>
    <data>
        <catalog>
            <book id="bk101">
                <author>Gambardella, Matthew</author>
                <title>XML Developer's Guide</title>
            </book>
        </catalog>
    </data>
</ajson:json>

XSLT

<?xml version="1.0"?>
<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform" xmlns:ajson="http://www.google.com">
    <xsl:output method="xml" encoding="utf-8" indent="yes" omit-xml-declaration="yes"/>
    <xsl:strip-space elements="*"/>

    <!-- template to copy without a namespace-->
    <xsl:template match="*">
        <xsl:element name="{local-name()}">
            <xsl:copy-of select="@*"/>
            <xsl:apply-templates/>
        </xsl:element>
    </xsl:template>

    <!-- template to remove document's root element -->
    <xsl:template match="/*">
        <xsl:apply-templates select="node()"/>
    </xsl:template>

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

    <xsl:template match="metadata">
    </xsl:template>
</xsl:stylesheet>

輸出 XML

<data>
  <catalog>
    <book id="bk101">
      <author>Gambardella, Matthew</author>
      <title>XML Developer's Guide</title>
    </book>
  </catalog>
</data>

uj5u.com熱心網友回復：

由于您的 XML 格式似乎是可變的，因此您只需要一個簡單的文本處理腳本。

Option Explicit

Sub Button1_Click()
    Dim fso As Object, ts As Object, filename As String
    Dim s As String, sOut As String, bData As Boolean
    
    'select file
    With Application.FileDialog(msoFileDialogFilePicker)
        If .Show <> -1 Then Exit Sub
        filename = .SelectedItems(1)
    End With
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.OpentextFile(filename)
   
    ' capture between <data> .... </data>
    Do While ts.AtEndOfStream <> True
        s = ts.readline
        If Trim(s) = "<data>" Then bData = True
        If bData Then sOut = sOut & s & vbCrLf
        If Trim(s) = "</data>" Then bData = False
    Loop
    Set ts = fso.CreateTextFile(filename, True)
    ts.Write sOut
    ts.Close
    MsgBox sOut
    
End Sub

uj5u.com熱心網友回復：

以下是使用 MSXML 物件在 VBA 中執行此操作的方法：

Sub Example()
    Dim myDoc As New MSXML2.DOMDocument60
    myDoc.LoadXML Sheet1.[A1].Value
    'myDoc now contains the example XML from your post
    Set myDoc = SetNewRoot(myDoc, "data")
    'MyDoc's root has now changed to data, all other nodes & elements are discarded.
End Sub

Function SetNewRoot(XMLDoc As MSXML2.DOMDocument60, TagName As String) As MSXML2.DOMDocument60
    Dim newDoc As New MSXML2.DOMDocument60
    Dim nodeSelect As IXMLDOMSelection
    Set nodeSelect = XMLDoc.getElementsByTagName(TagName)
    If nodeSelect.Length = 0 Then
        Set SetNewRoot = Nothing
    Else
        Dim newRoot As IXMLDOMNode
        Set newRoot = nodeSelect(0).CloneNode(deep:=True)
        newDoc.appendChild newRoot
        Set SetNewRoot = newDoc
    End If
End Function

此代碼使用 Microsoft XML v6.0 參考，將其添加到您的專案中以便能夠使用這些物件。要自動添加參考，請使用以下代碼：

Private Sub AddXMLRef()
    AddExcelRef ThisWorkbook, "{F5078F18-C551-11D3-89B9-0000F81FE221}", "MSXML2"
End Sub
Private Sub AddExcelRef(wbk As Workbook, sGuid As String, sRefName As String)
    Dim i As Integer
    On Error GoTo EH
    With wbk.VBProject.References
        For i = 1 To .Count
            If .Item(i).Name = sRefName Then
               Exit For
            End If
        Next i
        If i > .Count Then
           .AddFromGuid sGuid, 0, 0 ' 0,0 should pick the latest version installed on the computer
        End If
    End With
Exit Sub
EH:
    MsgBox "Error in 'AddRef'" & vbCrLf & vbCrLf & Err.Description
End Sub

標籤：擅长 xml vba

上一篇：在范圍內創建變數

下一篇：根據自定義順序對ADO記錄集欄位進行排序