如何实现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