VBA读写XML文件

Posted 2021-12-22 luoye00

‘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(0)

    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(0).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(1).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(34) & "1.0" & Chr(34) & _
                     " encoding=" & Chr(34) & "UTF-8" & Chr(34) & "?>" & vbCrLf
    stream.WriteText content

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

    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(1)
b = xdoc.Load(ThisWorkbook.Path & ".\Export.xml")
If b = True Then
    Set root = xdoc.DocumentElement ‘Get the root node
    fn = root.ChildNodes.Item(1).Text
    fp = root.ChildNodes.Item(0).Text & fn & "-" & Format(Now(), "yyyymmdd") & ".xlsx"
    irow = ThisWorkbook.Sheets(1).Range("a1000000").End(xlUp).Row
    ActiveWorkbook.Sheets(1).Copy
    ActiveWorkbook.SaveAs filename:=fp
    irow = .Range("A1000000").End(xlUp).Row
    .Range("A2:E" & irow).ClearContents
Else
    MsgBox "Error:failed to load xml file!", 16
End If
End With
End Sub