将文档保存到XML中，并将保存在XML中的文档还原。

时　间:2008-10-14 08:11:37
作　者:fan0217   ID：3202  城市：绵阳
摘　要:将文档保存到XML中，并将保存在XML中的文档还原。
正　文:

点击下载此附件

这是个有趣的过程，使用前先引用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 bjNode = objDoc.createProcessingInstruction("xml", "version='1.0' encoding='utf-8'")
    Set bjNode = objDoc.insertBefore(objNode, objDoc.childNodes.Item(0))
   
    Set bjRoot = objDoc.createElement("root")
    Set objDoc.documentElement = objRoot
        objRoot.setAttribute "xmlns:dt", "urn:schemas-microsoft-com:datatypes"
    Set bjNode = objDoc.createElement("document")
        objNode.text = GetFilename(strDocPath)
        objRoot.appendChild objNode
   
    Set bjNode = objDoc.createElement("createDate")
        objRoot.appendChild objNode
        Set bjEle = objNode
        objEle.nodeTypedValue = Format(Now, "yyyy-mm-dd hh:mm:ss")
      
    Set bjNode = objDoc.createElement("data")
        objRoot.appendChild objNode
    Set bjEle = 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 bjNode = 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 bjDoc = New DOMDocument
End Sub
Private Sub Class_Terminate()
    Set bjDoc = Nothing
End Sub
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