| 这是个有趣的过程，使用前先引用xml 创建个类模块：DocAndXml[code] Private objDoc As DOMDocument Public Sub DocToXml(strDocPath As String, strXmlPath As String) Dim objEle As IXMLDOMElement Dim objRoot As IXMLDOMElement Dim objNode As IXMLDOMNode objDoc.resolveExternals = True Set objNode = objDoc.createProcessingInstruction("xml", "version='1.0' encoding='utf-8'") Set objNode = objDoc.insertBefore(objNode, objDoc.childNodes.Item(0)) Set objRoot = objDoc.createElement("root") Set objDoc.documentElement = objRoot objRoot.setAttribute "xmlns:dt", "urn:schemas-microsoft-com:datatypes" Set objNode = objDoc.createElement("document") objNode.text = GetFilename(strDocPath) objRoot.appendChild objNode Set objNode = objDoc.createElement("createDate") objRoot.appendChild objNode Set objEle = objNode objEle.nodeTypedValue = Format(Now, "yyyy-mm-dd hh:mm:ss") Set objNode = objDoc.createElement("data") objRoot.appendChild objNode Set objEle = objNode objEle.DataType = "bin.base64" objEle.nodeTypedValue = ReadBinData(strDocPath) objDoc.Save strXmlPath End Sub Private Function ReadBinData(ByVal strFileName As String) As Variant Dim lLen As Long Dim iFile As Integer Dim arrBytes() As Byte Dim lCount As Long Dim strOut As String iFile = FreeFile() Open strFileName For Binary Access Read As iFile lLen = FileLen(strFileName) ReDim arrBytes(lLen - 1) Get iFile, , arrBytes Close iFile ReadBinData = arrBytes End Function Private Sub WriteBinData(ByVal strFileName As String) Dim iFile As Integer Dim arrBuffer() As Byte Dim objNode As IXMLDOMNode If Not (objDoc Is Nothing) Then Set objNode = objDoc.documentElement.selectSingleNode("/root/data") arrBuffer = objNode.nodeTypedValue iFile = FreeFile() Open strFileName For Binary Access Write As iFile Put iFile, , arrBuffer Close iFile End If End Sub Public Sub XmlToDoc(strDocPath As String, strXmlPath As String) If objDoc.Load(strXmlPath) Then WriteBinData strDocPath End If End Sub Private Function GetFilename(FilePath As String) As String Dim fso, pname Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(FilePath) Then Set pname = fso.GetFile(FilePath) GetFilename = pname.Name Set psize = Nothing Else GetFilename = "" End If Set fso = Nothing End Function Private Sub Class_Initialize() Set objDoc = New DOMDocument End Sub Private Sub Class_Terminate() Set objDoc = Nothing End Sub[/code][code] Dim objDoc As DOMDocument Dim strDocPath As String Dim strXmlPath As String Dim dx As New DocAndXml Sub DocToXmlTest() strDocPath = CurrentProject.Path & "\Book1.xls" strXmlPath = CurrentProject.Path & "\XmlOuput.xml" dx.DocToXml strDocPath, strXmlPath End Sub Sub XmlToDocTest() strDocPath = CurrentProject.Path & "\Test1.xls" strXmlPath = CurrentProject.Path & "\XmlOuput.xml" dx.XmlToDoc strDocPath, strXmlPath End Sub[/code] [hide][attach]32184[/attach][/hide]详细内容：http://www.office-cn.net/forum.php?mod=viewthread&tid=63960 |
|站长邮箱|小黑屋|手机版|Office中国/Access中国
( 粤ICP备10043721号-1 )
GMT+8, 2024-4-27 21:16 , Processed in 0.071596 second(s), 16 queries .
Powered by Discuz! X3.3
© 2001-2017 Comsenz Inc.
