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