VBA 生成XML(转)

Sub 按钮2_Click()

    Dim xmlFile As String

    xmlFile = "D:\test\books.xml"

    CreateXml xmlFile

End Sub

Function CreateXml(xmlFile As String)

    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("BookList")

    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("book")

    Set tNode = xDoc.DocumentElement.appendChild(newNode)

    tNode.setAttribute "type", "program"

    Set newNode = xDoc.createElement("name")

    Set tNode = xDoc.DocumentElement.ChildNodes.Item(0).appendChild(newNode)

    tNode.appendChild (xDoc.createTextNode("Thinking in Java"))

    Set newNode = xDoc.createElement("author")

    Set tNode = xDoc.DocumentElement.ChildNodes.Item(0).appendChild(newNode)

    tNode.appendChild (xDoc.createTextNode("Bruce Eckel"))

    Set newNode = xDoc.createElement("book")

    Set tNode = xDoc.DocumentElement.appendChild(newNode)

    tNode.setAttribute "type", "literature"

    Set newNode = xDoc.createElement("name")

    Set tNode = xDoc.DocumentElement.ChildNodes.Item(1).appendChild(newNode)

    tNode.appendChild (xDoc.createTextNode("边城"))

    Set newNode = xDoc.createElement("author")

    Set tNode = xDoc.DocumentElement.ChildNodes.Item(1).appendChild(newNode)

    tNode.appendChild (xDoc.createTextNode("沈从文"))

    Set newNode = Nothing

    Set tNode = Nothing

    Dim xmlStr As String

    xmlStr = PrettyPrintXml(xDoc)

    WriteUtf8WithoutBom xmlFile, xmlStr

    Set rootNode = Nothing

    Set xDoc = Nothing

    MsgBox xmlFile & "输出完成"

End Function

'格式化xml,带换行缩进

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

' utf8无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

    '移除前三个字节（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

---------------------

作者：luwhite

来源：CSDN

原文：https://blog.csdn.net/luwhite/article/details/52343305

版权声明：本文为博主原创文章，转载请附上博文链接！