ASP利用ＸＭＬ打包指定文件夹 并上传到ＷＥＢ目录中，自行解包

以前写的，发在

 http://www.xml.org.cn/dispbbs.asp?boardID=32&ID=23966

现在加在自己的BLOG中

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

前两天下了个Ｚ－ＢＬＯＧ，发现其安装程序有点意思，只有两个文件，一个数据文件，ＸＭＬ格式的，一个解包程序

 

此程序仿照Ｚ－ＢＬＯＧ的安装程序数据文件逆向写出
希望对那些不能批量上传文件的网友有帮助

' ========================
' 文件１
' Pack.asp
' 更改　Cpathname　这一变量
' 将在当前目录生成一个DATA.XML文件
' 将DATA.XML及文件２（install.asp)上传至ＷＥＢ根目录
' 运行install.asp解包
' 手动删除以上两个文件 
' ========================
< %  Option   Explicit  % >
< %  On   Error   Resume   Next  % >
< %
Server.ScriptTimeout = 99999999
dim  Cpathname
dim  startime,endtime

' 在此更改要打包文件夹的路径
Cpathname  =   " F:WEBsymr "

startime = timer ()
function  bianli(path)
  dim  doc
     dim  fso             ' fso对象
     dim  objFolder       ' 文件夹对象
     dim  objSubFolders   ' 子文件夹集合
     dim  objSubFolder    ' 子文件夹对象
     dim  objFiles        ' 文件集合
     dim  objFile         ' 文件对象
  dim  objStream
     dim  pathname,TextStream,pp,Xfolder,Xfpath,Xfile,Xpath,Xstream

     set  fso = server.CreateObject( " scripting.filesystemobject " )
     set  objFolder = fso.GetFolder(path) ' 创建文件夹对象
    
    Response.Write path
    Response.flush
    
  Set  doc  =  Server.CreateObject( " MSxml2.DOMDocument " )
 doc.load Server.MapPath( " data.xml " )
 doc.async = false
 
  ' 写入每个文件夹路径
  set  Xfolder  =  doc.SelectSingleNode( " //z-blog " ).AppendChild(doc.CreateElement( " folder " ))
  Set  Xfpath  =  Xfolder.AppendChild(doc.CreateElement( " path " ))
 Xfpath.text  =   replace (path,Cpathname, "" )
    
     set  objFiles = objFolder.Files
     for   each  objFile in objFiles
        Response.Write  "
--- "
     pp  =  path  &   " "   &  objFile.name
     
         Response.Write pp  &   "
"
      Response.flush

       ' ================================================
       ' 写入文件的路径及文件内容
    set  Xfile  =  doc.SelectSingleNode( " //z-blog " ).AppendChild(doc.CreateElement( " file " ))
   
    Set  Xpath  =  Xfile.AppendChild(doc.CreateElement( " path " ))
   Xpath.text  =   replace (pp,Cpathname, "" )
   
    ' 创建文件流读入文件内容，并写入XML文件中
    Set  objStream  =  Server.CreateObject( " ADODB.Stream " )
   objStream.Type  =   1
   objStream.Open()
   objStream.LoadFromFile(pp)
   objStream.position  =   0
   
    Set  Xstream  =  Xfile.AppendChild(doc.CreateElement( " stream " ))
   Xstream.SetAttribute  " xmlns:dt " , " urn:schemas-microsoft-com:datatypes "
    ' 文件内容采用二制方式存放
   Xstream.dataType  =   " bin.base64 "
   Xstream.nodeTypedValue  =  objStream.Read()
   
    set  objStream = nothing
    set  Xpath  =   nothing
    set  Xstream  =   nothing
    set  Xfile  =   nothing
   
       ' ================================================
     next
    Response.Write  " <p> "
 
 doc.save server.mappath( " data.xml " )
  set  Xfpath  =   nothing
  set  Xfolder  =   nothing
     set  doc  =   nothing
    
  ' 创建的子文件夹对象
  set  objSubFolders = objFolder.Subfolders
     ' 调用递归遍历子文件夹
     for   each  objSubFolder in objSubFolders
  pathname = path  +   " "   +  objSubFolder.name
  bianli(pathname)
     next  
    
     set  objFolder = nothing
     set  objSubFolders = nothing
     set  fso = nothing
end function

dim  doc,objPI
' 创建一个空的XML文件，为写入文件作准备
Set  doc  =  Server.CreateObject( " MSxml2.DOMDocument " )
doc.async = false
set  objPI  =  doc.createProcessingInstruction( " xml " , " version='1.0' encoding='UTF-8' " )
doc.insertBefore objPI, doc.childNodes( 0 )
doc.appendChild(doc.CreateElement( " z-blog " ))
doc.save server.mappath( " data.xml " )
set  objPI  =   nothing
set  doc  =   nothing
bianli(Cpathname) 
endtime = timer ()
% >  
页面执行时间： < % = FormatNumber ((endtime - startime), 3 )% > 秒

' =================================
' 文件２
' install.asp
' 此文件改自z-blog安装文件
' =================================
< %@ CODEPAGE = 65001  % >
< %  Option   Explicit  % >
< %  On   Error   Resume   Next  % >
< % Response.Charset = " UTF-8 "  % >
< html >
< head >
< title > 文件解包程序 </ title >
</ head >
< body >
< textarea name = " content "  cols = " 90 "  rows = " 20 "  style = " border:0px;overflow:auto;border-width:0px;width:100%;background-color:#E8F3FF; "  scrolling = " auto " >
< %
  Dim  strLocalPath
  ' 得到当前文件夹的物理路径
 strLocalPath = Left (Request.ServerVariables( " PATH_TRANSLATED " ), InStrRev (Request.ServerVariables( " PATH_TRANSLATED " ), " " ))

  Dim  strDbPath
  Dim  objXmlFile
  Dim  objNodeList
  Dim  objFSO
  Dim  objStream
  Dim  i,j

  Set  objXmlFile  =  Server.CreateObject( " Microsoft.XMLDOM " )
 objXmlFile.load(Server.MapPath( " data.xml " ))

If  objXmlFile.readyState = 4   Then
  If  objXmlFile.parseError.errorCode  =   0   Then

   Set  objNodeList  =  objXmlFile.documentElement.selectNodes( " //folder/path " )
   Set  objFSO  =   CreateObject ( " Scripting.FileSystemObject " )

  j = objNodeList.length - 1
   For  i = 0   To  j
    If  objFSO.FolderExists(strLocalPath  &  objNodeList(i).text) = False   Then
    objFSO.CreateFolder(strLocalPath  &  objNodeList(i).text)
    End   If
   Response.Write  " 创建目录 "   &  objNodeList(i).text  &  vbCrlf
   Response.Flush
   Next

   Set  objNodeList  =  objXmlFile.documentElement.selectNodes( " //file/path " )

  j = objNodeList.length - 1
   For  i = 0   To  j
    Set  objStream  =   CreateObject ( " ADODB.Stream " )
    With  objStream
   .Type  =   1
   .Open
   .Write objNodeList(i).nextSibling.nodeTypedvalue
   .SaveToFile strLocalPath  &  objNodeList(i).text, 2
   Response.Write  " 释放文件 "   &  objNodeList(i).text  &  vbCrlf
   Response.Flush
   .Close
    End   With
    Set  objStream  =   Nothing
   Next
  End   If
End   If
% >
</ textarea >
< %response.write  " <script>alert('文件解包完毕!');</script> " % >