如何实现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) & "秒 ")
 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("目录不存在，终止操作。 ")
 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 &"========== ") ' 输出目录
 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 & " "
 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 "" ' 段落分隔符
 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 "创建目录： "
 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 & " "
 Response.Flush
 Next
 Set objNodeList = Nothing
 Response.Write "" ' 段落分隔符
 Set objNodeList = objXmlDoc.documentElement.selectNodes("//file/path")
 intJ = objNodeList.length - 1
 Response.Write "释放文件： "
 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(""& Err.Description &"")
 Err.Clear
 End If
 Response.Write objNodeList(intI).text & " "
 Response.Flush
 Next
 Set objNodeList = Nothing
 End If
 End If
 Response.Write("完成任务<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("检测运行所需环境时出现错误，请检查组件" & arrObj(intI) & "是否正常运行，程序终止。 ")
 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

posted @ 2009-04-17 19:38 Athrun 阅读(921) 评论(0) 编辑收藏举报

刷新页面返回顶部

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

公告