如何实现ASP在线打包解包文件,存储格式XML版

　　使用XML存储方式打包的文件大小会比原文件增大40%左右，所以一般情况下不推荐使用XML存储方式，推荐使用数据流文件或MDB文件存储方式。

本文应用到的技术：
ASP Microsoft.XMLDOM组件创建及操作XML文档(XML保存二进制数据)，用到的相关方法及属性：.Load,.async,.AppendChild,.createProcessingInstruction,.CreateElement,.Save,.SelectSingleNode,.Text,.SetAttribute,.SetAttribute,.dataType,.nodeTypedValue,.selectNodes,.length,.nextSibling,.documentElement

ASP Fso Scripting.FileSystemObject对象的GetFolder、FolderExists、CreateFolder方法的应用，GetFolder的Files(文件集合)、SubFolders(子文件夹)操作，遍历文件夹及文件

ASP ADODB.Stream读取、写入文件，应用的相关属性及方法：.Type,.Open,.LoadFromFile,.Read,.Write,.Close

ASP打包类 For XML实现源代码

 

<%@LANGUAGE="VBSCRIPT" CODEPAGE="65001"%>
<%
Option Explicit
Response.Buffer = True
Response.Charset = "utf-8"
Server.ScriptTimeout = 999999999

'文件打包类 To Xml
'使用前请先确保目标文件具有读写权限，否则将因无法创建文件而导致程序出错
' 类属性：
'    PackFile    打包文件名,默认Pack.xml
'    PackPath    打包路径,默认程序所在目录"./"
'    UnPackFile    解包文件名,默认Pack.xml
'    UnPackPath    解包路径,默认程序所在目录"./"
'类方法：
'    Pack        打包
'    UnPack        解包

Class Pack2Xml

    Private dtmStart, dtmEnd
    Private strPackFile, strPackPath, strUnPackFile, strUnPackPath, strErr
    Private objXmlDoc, objFso, objStream

    ' Set Initialize
    Private Sub Class_Initialize
        dtmStart = Timer()    ' 程序运行开始时间
        Call CheckObjInstalled("Microsoft.XMLDOM,Scripting.FileSystemObject,Adodb.Stream")    ' 测试所需环境
        Set objFso = Server.CreateObject("Scripting.FileSystemObject")
        Set objXmlDoc = Server.CreateObject("Microsoft.XMLDOM")
        Set objStream = Server.CreateObject("ADODB.Stream")
        strPackPath = "./" ' 打包目录路径
        strPackFile = "Pack.xml" ' 打包文件名
        strPackPath = Server.MapPath(strPackPath) & "\"
        strPackFile = Server.MapPath(strpackFile)
        strUnPackFile = strPackFile
        strUnPackPath = strPackPath
    End Sub
    
    ' Set Terminate
    Private Sub Class_Terminate
        Set objFso = Nothing
        Set objXmlDoc = Nothing
        Set objStream = Nothing
        dtmEnd = Timer()    ' 程序执行结束时间
        Response.Write("程序执行时间：" & FormatNumber((dtmEnd-dtmStart),3) & "秒<br />")
    End Sub

    ' Set PackPath
    Public Property Let PackPath(strPath)
        strPackPath = Server.MapPath(strPath) & "\"
    End Property

    ' Set PackPath
    Public Property Let UnPackPath(strPath)
        strUnPackPath = Server.MapPath(strPath) & "\"
    End Property

    ' Set pack file
    Public Property Let PackFile(strName)
        strPackFile = Server.MapPath(strName)
    End Property

    ' Set unpack file
    Public Property Let UnPackFile(strName)
        strUnPackFile = Server.MapPath(strName)
    End Property

    Public Sub Pack()
        Call CreateXml(strPackFile)
        objXmlDoc.async = False
        objXmlDoc.load(strPackFile)
        Response.Write("开始任务：执行打包目录：" & strPackPath & "<hr />")
        If objFSO.FolderExists(strPackPath) = False Then
            Response.Write("目录不存在，终止操作。<br />")
            Exit Sub
        Else
            Call LoadData(strPackPath)
        End If
        Response.Write("完成任务：数据文件保存于：" & strPackFile & "<hr />")
    End Sub

    Private Sub LoadData(DirPath)
        Dim objFolder, objSubFolder, objSubFolders, objFile, objFiles
        Dim objXFolder, objXFPath, objXFile, objXPath, objXStream
        Dim strPathName, strSubFolderPath

        Response.Write("=========="& DirPath &"==========<br />")    ' 输出目录
        Response.Flush
        Set objFolder = objFso.GetFolder(DirPath)    ' 创建文件夹对象
        Set objXFolder = objXmlDoc.SelectSingleNode("//root").AppendChild(objXmlDoc.CreateElement("folder"))
        Set objXFPath = objXFolder.AppendChild(objXmlDoc.CreateElement("path"))
            objXFPath.Text = Replace(DirPath,strPackPath,"")    ' 写入文件夹路径
        Set objFiles = objFolder.Files    ' 文件集合
        For Each objFile In objFiles    ' 遍历当前文件夹下的文件
            If LCase(DirPath & objFile.Name) <> LCase(Request.ServerVariables("PATH_TRANSLATED")) Then    ' 不对自己进行打包
                strPathName = DirPath & objFile.Name
                Response.Write strPathName & "<br />"
                Response.Flush
                '写入文件的路径及文件内容
                set objXFile = objXmlDoc.SelectSingleNode("//root").AppendChild(objXmlDoc.CreateElement("file"))
                Set objXPath = objXFile.AppendChild(objXmlDoc.CreateElement("path"))
                    objXPath.Text = replace(strPathName,strPackPath,"")
                '以数据流方式读入文件内容，并写入XML文件中
                With objStream
                    .Type = 1
                    .Open()
                    .LoadFromFile(strPathName)
                End With

                Set objXStream = objXFile.AppendChild(objXmlDoc.CreateElement("stream"))
                With objXStream
                    .SetAttribute "xmlns:dt","urn:schemas-microsoft-com:datatypes"
                    .dataType = "bin.base64"    ' 文件内容采用二进制存放
                    .nodeTypedValue = objStream.Read()
                End With

                objStream.Close
                Set objXPath = Nothing
                Set objXFile = Nothing
                Set objXStream = Nothing
            End If
        Next
        Response.Write "<p></p>"    ' 段落分隔符
        objXmlDoc.Save(strPackFile)
        Set objXFPath = Nothing
        Set objXFolder = Nothing
        
        Set objSubFolders = objFolder.SubFolders    ' 创建子文件夹对象
        For Each objSubFolder In objSubFolders    ' 调用递归遍历子文件夹
            strSubFolderPath = DirPath & objSubFolder.Name & "\"
            Call LoadData(strSubFolderPath)
        Next
        Set objFolder = Nothing
        Set objSubFolders = Nothing
    End Sub

    Public Sub UnPack()
        On Error Resume Next
        Dim objNodeList
        Dim intI, intJ
        Response.Write("开始任务：解包文件：" & strUnPackFile & "，解包目录：" & strUnPackPath & "<hr />")
        objXmlDoc.async = False
        objXmlDoc.load(strUnPackFile)
        If objXmlDoc.readyState = 4 Then
            If objXmlDoc.parseError.errorCode = 0 Then
                Set objNodeList = objXmlDoc.documentElement.selectNodes("//folder/path")
                intJ = objNodeList.length - 1
                Response.Write "<strong>创建目录：</strong><br />"
                For intI=0 To intJ
                    If objFSO.FolderExists(strUnPackPath & objNodeList(intI).text) = False Then
                        objFSO.CreateFolder(strUnPackPath & objNodeList(intI).text)
                    End If
                    Response.Write objNodeList(intI).text & "<br />"
                    Response.Flush
                Next
                Set objNodeList = Nothing
                Response.Write "<p></p>"    ' 段落分隔符
                Set objNodeList = objXmlDoc.documentElement.selectNodes("//file/path")
                intJ = objNodeList.length - 1
                Response.Write "<strong>释放文件：</strong><br/>"
                For intI=0 To intJ
                    With objStream
                        .Type = 1
                        .Open
                        .Write objNodeList(intI).nextSibling.nodeTypedvalue
                        .SaveToFile strUnPackPath & objNodeList(intI).text,2
                        .Close
                    End With
                    If Err Then    ' 可能出现：“写入文件失败。”的错误提示，这是因为在重写含有：只读、系统、隐藏的文件时会造成写入失败,与文件系统类型无关
                        Response.Write("<span style=""color:#FF0000"">"& Err.Description &"</span>")
                        Err.Clear
                    End If
                    Response.Write objNodeList(intI).text & "<br/>"
                    Response.Flush
                Next
                Set objNodeList = Nothing
            End If
        End If
        Response.Write("<p></p>完成任务<hr />")
    End Sub
    
    ' Check module install
    Private Sub CheckObjInstalled(strObj)
        On Error Resume Next
        Dim objTest
        Dim arrObj
        Dim intI
        arrObj = Split(strObj,",")
        For intI = 0 To Ubound(arrObj,1)
            Set objTest = Server.CreateObject(arrObj(intI))
            If Err Then
                Err.Clear
                Call OutErr("检测运行所需环境时出现错误，请检查组件<strong>" & arrObj(intI) & "</strong>是否正常运行，程序终止。<br />")
            End If
            Set objTest = Nothing    
        Next
    End Sub

    ' Create new xml file
    Private Sub CreateXml(FilePath)
        objXmlDoc.async = False
        objXmlDoc.appendChild(objXmlDoc.createProcessingInstruction("xml","version='1.0' encoding='UTF-8'"))
        objXmlDoc.appendChild(objXmlDoc.CreateElement("root"))
        objXmlDoc.Save(FilePath)
    End Sub

    Private Sub OutErr(strChar)
        Response.Write(strChar):Response.End()
    End Sub

End Class
%>

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<title>ASP XML打包解包工具</title>
</head>

<body>
<%
Dim objPack
Set objPack = New Pack2Xml    ' 创建类实例

If Request.QueryString("act") = "pack" Then
    'objPack.PackFile = "Pack.xml"
    'objPack.PackPath = "./"
    objPack.Pack    ' 执行打包
Else
    'objPack.UnPackFile = "Pack.xml"
    'objPack.UnPackPath = "./"
    objPack.UnPack    ' 执行解包
End If

Set objPack = Nothing
%>
</body>
</html>

 

 PACK ASP