日志

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

已有 1884 次阅读2008-9-22 06:44 |个人分类:Access

这是个有趣的过程，使用前先引用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

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

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

收藏分享邀请使用道具 | 编辑| 删除|

的个人空间 http://www.office-cn.net/?0 [收藏] [复制] [分享] [RSS]

日志

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

评论 (0 个评论)