'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
转载于:https://www.cnblogs.com/luoye00/p/10979593.html
相关资源：vbscript 读取xml格式的配置文件
