不用额外组件的ASP在线打包程序

方式一（荐）：
ZipAndUnZip.asp

1. 
   
2. <%
   
3. Sub AddToMdb(thePath)
   
4. On Error Resume Next
   
5. Dim Rs, Conn, Stream, ConnStr, adoCatalog, FsoX
   
6. Set FsoX = CreateObject("Scripting.FileSystemObject")
   
7. If FsoX.FileExists(Server.MapPath("HYTop.mdb")) Then
   
8. FsoX.DeleteFile(Server.MapPath("HYTop.mdb"))
   
9. End If
   
10. Set Rs = Server.CreateObject("Adodb.RecordSet")
    
11. Set Stream = Server.CreateObject("Adodb.Stream")
    
12. Set Conn = Server.CreateObject("Adodb.Connection")
    
13. Set adoCatalog = Server.CreateObject("ADOX.Catalog")
    
14. ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("HYTop.mdb")
    
15. adoCatalog.Create ConnStr
    
16. Conn.Open ConnStr
    
17. Conn.Execute("Create Table FileData(Id int IDENTITY(0,1) Primary Key Clustered, thePath VarChar, fileContent Image)")
    
18. Stream.Open
    
19. Stream.Type = 1
    
20. Rs.Open "FileData", Conn, 3, 3
    
21. fsoTreeForMdb thePath, Rs, Stream  
    
22. Rs.Close
    
23. Conn.Close
    
24. Stream.Close
    
25. Set Rs = Nothing
    
26. Set Conn = Nothing
    
27. Set Stream = Nothing
    
28. Set adoCatalog = Nothing
    
29. End Sub
    
30. Sub fsoTreeForMdb(ThePath, Rs, Stream)
    
31. Dim Item, TheFolder, Folders , Files, SysFileList, FsoX
    
32. Set FsoX = Server.CreateObject("Scripting.FileSystemObject")
    
33. SysFileList = "$HYTop.mdb$HYTop.ldb$"
    
34. 
    
35. If FsoX.FolderExists(ThePath) = False Then
    
36. Response.write(ThePath + " 目录不存在或不允许访问!")
    
37. End If
    
38. Set TheFolder = FsoX.GetFolder(ThePath)
    
39. Set Files = TheFolder.Files
    
40. Set Folders = TheFolder.SubFolders
    
41. For Each Item In Folders
    
42. fsoTreeForMdb Item.Path, Rs, Stream
    
43. Next
    
44. For Each Item In Files
    
45. If InStr(SysFileList, "$" & Item.Name & "$") <= 0 Then
    
46. Rs.AddNew
    
47. Rs("thePath") = Mid(Item.Path, Len(Request("thePath")) + 1)
    
48. Stream.LoadFromFile(Item.Path)
    
49. Rs("fileContent") = Stream.Read()
    
50. Rs.Update
    
51. End If
    
52. Next
    
53. Set Files = Nothing
    
54. Set Folders = Nothing
    
55. Set TheFolder = Nothing
    
56. Set FsoX = Nothing
    
57. End Sub
    
58. 
    
59. Sub unPack(thePath)
    
60. On Error Resume Next
    
61. Server.ScriptTimeOut = 5000
    
62. Dim Rs, Ws, Str, Conn, Stream, ConnStr, theFolder, FsoX
    
63. Str = Server.MapPath(".") & ""
    
64. Set FsoX = CreateObject("Scripting.FileSystemObject")
    
65. Set Rs = CreateObject("Adodb.RecordSet")
    
66. Set Stream = CreateObject("Adodb.Stream")
    
67. Set Conn = CreateObject("Adodb.Connection")
    
68. ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & thePath & ";"
    
69. Conn.Open ConnStr
    
70. Rs.Open "Select * from FileData", Conn, 1, 1
    
71. Stream.Open
    
72. Stream.Type = 1
    
73. Do Until Rs.Eof
    
74. TheFolder = Left(Rs("thePath"), InStrRev(Rs("thePath"), ""))
    
75. If FsoX.FolderExists(Str & theFolder) = False Then
    
76. CreateFolder(Str & theFolder)
    
77. End If
    
78. Stream.SetEos()
    
79. Stream.Write Rs("fileContent")
    
80. Stream.SaveToFile Str & Rs("thePath") , 2
    
81. Rs.MoveNext
    
82. Loop
    
83. Rs.Close
    
84. Conn.Close
    
85. Stream.Close
    
86. Set Ws = Nothing
    
87. Set Rs = Nothing
    
88. Set Stream = Nothing
    
89. Set Conn = Nothing
    
90. Set FsoX = Nothing
    
91. End Sub
    
92. Sub CreateFolder(thePath)
    
93. Dim i, FsoX
    
94. Set FsoX = CreateObject("Scripting.FileSystemObject")
    
95. i = Instr(thePath, "")
    
96. Do While i >0
    
97. If FsoX.FolderExists(Left(thePath, i)) = False Then
    
98. FsoX.CreateFolder(Left(thePath, i - 1))
    
99. End If
    
100. If InStr(Mid(thePath, i + 1), "") Then
     
101. i = i + Instr(Mid(thePath, i + 1), "")
     
102. Else
     
103. i = 0
     
104. End If
     
105. Loop
     
106. End Sub
     
107. If Trim(Request("Zip")) <> "" Then
     
108. AddToMdb(Request("thePath"))
     
109. Response.Write("压缩文件完毕! ")
     
110. Response.Write("<a href=HYTop.mdb>下载压缩文件</a>")
     
111. End If
     
112. If Trim(Request("UnZip")) <> "" Then
     
113. unPack(Request("theFile"))
     
114. Response.Write("解压完毕!")
     
115. End If
     
116. %>
     
117. <style type="text/css">
     
118. <!--
     
119. .STYLE1 {color: #FF0000}
     
120. .STYLE2 {
     
121. color: #FFFFFF;
     
122. font-weight: bold;
     
123. font-size: 14px;
     
124. }
     
125. *{font-size:12px;}
     
126. -->
     
127. </style>
     
128. <p>&nbsp;</p>
     
129. <p>&nbsp;</p>
     
130. <p>&nbsp;</p>
     
131. <p>&nbsp;</p>
     
132. <form id="form1" name="form1" method="post" action="">
     
133. <table width="100%" height="25" border="0" cellpadding="0" cellspacing="1" bgcolor="#66CCCC">
     
134. <tr>
     
135. <td height="30" colspan="3" align="center"><span class="STYLE2">ASP 在线压缩-解压缩</span></td>
     
136. </tr>
     
137. <tr>
     
138. <td width="35%" height="25" bgcolor="#FFFFFF">压缩目录(压缩完成后默认为本程序目录下 <span class="STYLE1">HYTop.mdb</span> 文件)</td>
     
139. <td width="41%" height="25" bgcolor="#FFFFFF">
     
140. &nbsp; <input name="thePath" type="text" id="thePath" value="<% If Right(Server.MapPath("."), 1) <> "" Then Response.Write(Server.MapPath(".")) & "" Else Response.Write(Server.MapPath(".")) End If %>" size="60" /></td>
     
141. <td width="24%" height="25" bgcolor="#FFFFFF"><input name="Zip" type="submit" id="Zip" value="在线压缩" /></td>
     
142. </tr>
     
143. <tr>
     
144. <td height="25" bgcolor="#FFFFFF">解压缩文件(默认为本程序目录下 <span class="STYLE1">HYTop.mdb</span> 文件)</td>
     
145. <td height="25" bgcolor="#FFFFFF">&nbsp; <input name="theFile" type="text" id="theFile" value="<%=Server.MapPath("HYTop.mdb")%>" size="60" /></td>
     
146. <td height="25" bgcolor="#FFFFFF">
     
147. <input name="UnZip" type="submit" id="UnZip" value="在线解压缩" /></td>
     
148. </tr>
     
149. </table>
     
150. </form>
     

复制代码

方式二：
index.asp文件

1. 
   
2. <% Option Explicit %>
   
3. <!--#include file="asptar.asp"-->
   
4. <%
   
5. Response.charset="gb2312"
   
6. Response.Buffer = True
   
7. Response.Clear
   
8. Dim Co,Temp,T,x,i,fsoBrowse,theFolder,TheSubFolders,FilePath,s,PH,objTar
   
9. Co=0
   
10. PH="../zip" '文件路径 '压缩父目录下zip目录的所有文件
    
11. Set objTar = New Tarball
    
12. objTar.TarFilename="打包.rar"   '打包的名称
    
13. objTar.Path=PH
    
14. set fsoBrowse=CreateObject("Scripting.FileSystemObject")
    
15. Set theFolder=fsoBrowse.GetFolder(Server.Mappath(PH))
    
16. Set theSubFolders=theFolder.SubFolders
    
17. GetFileList theFolder,""
    
18. 
    
19. If Co<1 Then
    
20. Response.Write "暂时没有可更新的文件下载"
    
21. 'objTar.AddMemoryFile "Sorry.txt","Not File!"
    
22. Else
    
23. Temp=Left(Temp,Len(Temp)-1)
    
24. FilePath=Split(Temp,"|")
    
25. For s=0 To Ubound(FilePath)
    
26. objTar.AddFile Server.Mappath(PH & "/" & FilePath(s))
    
27. Next
    
28. If Response.IsClientConnected Then
    
29. objTar.WriteTar
    
30. Response.Flush
    
31. End If
    
32. End If
    
33. Set ObjTar = Nothing
    
34. Set fsoBrowse= Nothing
    
35. Set theFolder = Nothing
    
36. Set theSubFolders = Nothing
    
37. Sub GetFileList(Folderobject,path)
    
38. Dim y,m
    
39. For Each y in Folderobject.Files
    
40. If Path <>"" Then
    
41. Temp= Temp &   path & y.Name&"|"
    
42. Else
    
43. Temp= Temp & y.Name&"|"
    
44. End If
    
45. Co=Co+1
    
46. Next
    
47. Dim NewPath
    
48. For Each m In Folderobject.SubFolders
    
49. If path="" Then
    
50. NewPath=M.name &"/"
    
51. Else
    
52. NewPath=path & M.name &"/"
    
53. End If
    
54. GetFileList m,NewPath
    
55. Next
    
56. End Sub
    
57. %>
    

复制代码

asptar.asp文件

1. 
   
2. <%
   
3. 
   
4. Class Tarball
   
5. Public TarFilename    ' Resultant tarball filename
   
6. 
   
7. Public UserID     ' UNIX user ID
   
8. Public UserName     ' UNIX user name
   
9. Public GroupID     ' UNIX group ID
   
10. Public GroupName    ' UNIX group name
    
11. 
    
12. Public Permissions    ' UNIX permissions
    
13. 
    
14. Public BlockSize    ' Block byte size for the tarball (default=512)
    
15. 
    
16. Public IgnorePaths    ' Ignore any supplied paths for the tarball output
    
17. Public BasePath     ' Insert a base path with each file
    
18. Public Path
    
19. 
    
20. ' Storage for file information
    
21. Private objFiles,TmpFileName
    
22. Private objMemoryFiles
    
23. 
    
24. ' File list management subs, very basic stuff
    
25. Public Sub AddFile(sFilename)
    
26. objFiles.Add sFilename,sFilename
    
27. End Sub
    
28. 
    
29. Public Sub RemoveFile(sFilename)
    
30. objFiles.Remove sFilename
    
31. End Sub
    
32. 
    
33. Public Sub AddMemoryFile(sFilename,sContents)
    
34. objMemoryFiles.Add sFilename,sContents
    
35. End Sub
    
36. 
    
37. Public Sub RemoveMemoryFile(sFilename)
    
38. objMemoryFiles.Remove sFilename
    
39. End Sub
    
40. 
    
41. Public Sub WriteTar()
    
42. Dim objStream, objInStream, lTemp, aFiles
    
43. Set objStream = Server.CreateObject("ADODB.Stream") ' The main stream
    
44. Set objInStream = Server.CreateObject("ADODB.Stream") ' The input stream for data
    
45. objStream.Type = 2
    
46. objStream.Charset = "x-ansi" ' Good old extended ASCII
    
47. objStream.Open
    
48. 
    
49. objInStream.Type = 2
    
50. objInStream.Charset = "x-ansi"
    
51. 
    
52. aFiles = objFiles.Items
    
53. For lTemp = 0 to UBound(aFiles)
    
54. objInStream.Open
    
55. objInStream.LoadFromFile aFiles(lTemp)
    
56. objInStream.Position = 0
    
57. TmpFileName =replace(aFiles(lTemp),Server.Mappath(Path)&"","")
    
58. ExportFile TmpFileName,objStream,objInStream
    
59. objInStream.Close
    
60. Next
    
61. aFiles = objMemoryFiles.Keys
    
62. For lTemp = 0 to UBound(aFiles)
    
63. objInStream.Open
    
64. objInStream.WriteText objMemoryFiles.Item(aFiles(lTemp))
    
65. objInStream.Position = 0
    
66. ExportFile aFiles(lTemp),objStream,objInStream
    
67. objInStream.Close
    
68. Next
    
69. 
    
70. objStream.WriteText String(BlockSize,Chr(0))
    
71. objStream.Position = 0
    
72. objStream.Type = 1
    
73. objStream.savetofile Server.Mappath(Path) & "" & TarFilename,2
    
74. objStream.Close
    
75. Set objStream = Nothing
    
76. Set objInStream = Nothing
    
77. End Sub
    
78. 
    
79. ' Build a header for each file and send the file contents
    
80. Private Sub ExportFile(sFilename,objOutStream,objInStream)
    
81. Dim lStart, lSum, lTemp
    
82. lStart = objOutStream.Position ' Record where we are up to
    
83. If IgnorePaths Then
    
84. ' We ignore any paths prefixed to our filenames
    
85. lTemp = InStrRev(sFilename,"")
    
86. if lTemp <> 0 then
    
87. sFilename = Right(sFilename,Len(sFilename) - lTemp)
    
88. end if
    
89. sFilename = BasePath & sFilename
    
90. End If
    
91. 
    
92. ' Build the header, everything is ASCII in octal except for the data
    
93. 'objOutStream.charset="gb2312"
    
94. objOutStream.WriteText Left(sFilename & String(100,Chr(0)),100)
    
95. 'objOutStream.charset="x-ansi"
    
96. objOutStream.WriteText "100" & Right("000" & Oct(Permissions),3) & " " & Chr(0) 'File mode
    
97. objOutStream.WriteText Right(String(6," ") & CStr(UserID),6) & " " & Chr(0) 'uid
    
98. objOutStream.WriteText Right(String(6," ") & CStr(GroupID),6) & " " & Chr(0) 'gid
    
99. objOutStream.WriteText Right(String(11,"0") & Oct(objInStream.Size),11) & Chr(0) 'size
    
100. objOutStream.WriteText Right(String(11,"0") & Oct(dateDiff("s","1/1/1970 10:00",now())),11) & Chr(0) 'mtime (Number of seconds since 10am on the 1st January 1970 (10am correct?)
     
101. objOutStream.WriteText "         0" & String(100,Chr(0)) 'chksum, type flag and link name, write out all blanks so that the actual checksum will get calculated correctly
     
102. objOutStream.WriteText "ustar   "   & Chr(0) 'magic and version
     
103. objOutStream.WriteText Left(UserName & String(32,Chr(0)),32) 'uname
     
104. objOutStream.WriteText Left(GroupName & String(32,Chr(0)),32) 'gname
     
105. objOutStream.WriteText "          40 " & String(4,Chr(0)) 'devmajor, devminor
     
106. objOutStream.WriteText String(167,Chr(0)) 'prefix and leader
     
107. objInStream.CopyTo objOutStream ' Send the data to the stream
     
108. 
     
109. if (objInStream.Size Mod BlockSize) > 0 then
     
110. objOutStream.WriteText String(BlockSize - (objInStream.Size Mod BlockSize),Chr(0)) 'Padding to the nearest block byte boundary
     
111. end if
     
112. 
     
113. ' Calculate the checksum for the header
     
114. lSum = 0  
     
115. objOutStream.Position = lStart
     
116. 
     
117. For lTemp = 1 To BlockSize
     
118. lSum = lSum + (Asc(objOutStream.ReadText(1)) And &HFF&)
     
119. Next
     
120. 
     
121. ' Insert it
     
122. objOutStream.Position = lStart + 148
     
123. objOutStream.WriteText Right(String(7,"0") & Oct(lSum),7) & Chr(0)
     
124. 
     
125. ' Move to the end of the stream
     
126. objOutStream.Position = objOutStream.Size
     
127. End Sub
     
128. 
     
129. ' Start everything off
     
130. Private Sub Class_Initialize()
     
131. Set objFiles = Server.CreateObject("Scripting.Dictionary")
     
132. Set objMemoryFiles = Server.CreateObject("Scripting.Dictionary")
     
133. 
     
134. BlockSize = 512
     
135. Permissions = 438 ' UNIX 666
     
136. UserID = 0
     
137. UserName = "root"
     
138. GroupID = 0
     
139. GroupName = "root"
     
140. IgnorePaths = False
     
141. BasePath = ""
     
142. TarFilename = "new.tar"
     
143. End Sub
     
144. 
     
145. Private Sub Class_Terminate()
     
146. Set objMemoryFiles = Nothing
     
147. Set objFiles = Nothing
     
148. End Sub
     
149. End Class
     
150. %>
     

复制代码