日志

將文檔保存到XML中，并將保存在XML中的文檔還原。

已有 1944 次閱讀2008-9-22 06:44 |個人分類:Access

這是個有趣的過程，使用前先引用xml

創(chuàng)建個類模塊：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

[ 本帖最后由 fan0217 于 2008-9-20 23:54 編輯 ]

FileAndXML.rar
(2008-09-20 23:54:14, Size: 298 KB, Downloads: 0)