VBA读写XML文件

'Write XML file
Sub WriteXML(fpa$, fn$)
    Dim xmlfile As String
    xmlfile = ThisWorkbook.Path & ".\Export.xml"
    CreateXml xmlfile, fpa, fn
End Sub

Function CreateXml(xmlfile$, fpa$, fn$)
    Dim xdoc As Object
    Dim rootNode As Object
    Dim header As Object
    Dim newNode As Object
    Dim tNode As Object

    Set xdoc = CreateObject("MSXML2.DOMDocument")
    Set rootNode = xdoc.createElement("FilePath")
    Set xdoc.DocumentElement = rootNode
    'xDoc.Load xmlFile
    Set header = xdoc.createProcessingInstruction("xml", "version='1.0' encoding='Unicode'")
    xdoc.InsertBefore header, xdoc.ChildNodes()

    Set newNode = xdoc.createElement("File")
    Set tNode = xdoc.DocumentElement.appendChild(newNode)
    tNode.setAttribute "type", "folder"

    Set newNode = xdoc.createElement("path")
    Set tNode = xdoc.DocumentElement.ChildNodes.Item().appendChild(newNode)
    tNode.appendChild (xdoc.createTextNode(fpa))

    Set newNode = xdoc.createElement("File")
    Set tNode = xdoc.DocumentElement.appendChild(newNode)
    tNode.setAttribute "type", "file"

    Set newNode = xdoc.createElement("name")
    Set tNode = xdoc.DocumentElement.ChildNodes.Item().appendChild(newNode)
    tNode.appendChild (xdoc.createTextNode(fn))

    Set newNode = Nothing
    Set tNode = Nothing

    Dim xmlStr As String
    xmlStr = PrettyPrintXml(xdoc)
    WriteUtf8WithoutBom xmlfile, xmlStr

    Set rootNode = Nothing
    Set xdoc = Nothing

    'MsgBox xmlFile & "XML file exported sucessfully!"
   ' Call export_data(fpa, fn)
End Function

'Formatting XML,set wrapping and indentation
Function PrettyPrintXml(xmldoc) As String
    Dim reader As Object
    Dim writer As Object
    Set reader = CreateObject("Msxml2.SAXXMLReader.6.0")
    Set writer = CreateObject("Msxml2.MXXMLWriter.6.0")
    writer.indent = True
    writer.omitXMLDeclaration = True
    reader.contentHandler = writer
    reader.Parse (xmldoc)
    PrettyPrintXml = writer.Output
End Function

'UTF-8 without BOM
Function WriteUtf8WithoutBom(filename As String, content As String)
    Dim stream As New ADODB.stream
    stream.Open
    stream.Type = adTypeText
    stream.Charset = "utf-8"
    stream.WriteText "<?xml version=" & Chr() & "1.0" & Chr() & _
                     " encoding=" & Chr() & "UTF-8" & Chr() & "?>" & vbCrLf
    stream.WriteText content

    'Top 3 character move sets£¨0xEF,0xBB,0xBF£©
    stream.Position = 

    Dim newStream As New ADODB.stream
    newStream.Type = adTypeBinary
    newStream.Mode = adModeReadWrite
    newStream.Open

    stream.CopyTo newStream
    stream.Flush
    stream.Close

    newStream.SaveToFile filename, adSaveCreateOverWrite
    newStream.Flush
    newStream.Close
End Function

Sub export_data()
Dim xdoc As New DOMDocument60 'Declare and create XML object
Dim b As Boolean, root As IXMLDOMElement
Dim fp As String
Dim fn As String
Dim wb As Workbook
Dim arr() As String
Dim i As Integer
Dim j As Integer
Dim app As Object
Dim wbs As Workbook
Dim ws As Worksheet
Dim irow As Integer
On Error Resume Next
With ThisWorkbook.Sheets()
b = xdoc.Load(ThisWorkbook.Path & ".\Export.xml")
If b = True Then
    Set root = xdoc.DocumentElement 'Get the root node
    fn = root.ChildNodes.Item().Text
    fp = root.ChildNodes.Item().Text & fn & "-" & Format(Now(), "yyyymmdd") & ".xlsx"
    irow = ThisWorkbook.Sheets().Range("a1000000").End(xlUp).Row
    ActiveWorkbook.Sheets().Copy
    ActiveWorkbook.SaveAs filename:=fp
    irow = .Range("A1000000").End(xlUp).Row
    .Range("A2:E" & irow).ClearContents
Else
    MsgBox "Error:failed to load xml file!",
End If
End With
End Sub