方式一（荐）：
ZipAndUnZip.asp
<%
Sub AddToMdb(thePath)
On Error Resume Next
Dim Rs, Conn, Stream, ConnStr, adoCatalog, FsoX
Set FsoX = CreateObject("Scripting.FileSystemObject")
If FsoX.FileExists(Server.MapPath("HYTop.mdb")) Then
FsoX.DeleteFile(Server.MapPath("HYTop.mdb"))
End If
Set Rs = Server.CreateObject("Adodb.RecordSet")
Set Stream = Server.CreateObject("Adodb.Stream")
Set Conn = Server.CreateObject("Adodb.Connection")
Set adoCatalog = Server.CreateObject("ADOX.Catalog")
ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("HYTop.mdb")
adoCatalog.Create ConnStr
Conn.Open ConnStr
Conn.Execute("Create Table FileData(Id int IDENTITY(0,1) Primary Key Clustered, thePath VarChar, fileContent Image)")
Stream.Open
Stream.Type = 1
Rs.Open "FileData", Conn, 3, 3
fsoTreeForMdb thePath, Rs, Stream
Rs.Close
Conn.Close
Stream.Close
Set Rs = Nothing
Set Conn = Nothing
Set Stream = Nothing
Set adoCatalog = Nothing
End Sub
Sub fsoTreeForMdb(ThePath, Rs, Stream)
Dim Item, TheFolder, Folders , Files, SysFileList, FsoX
Set FsoX = Server.CreateObject("Scripting.FileSystemObject")
SysFileList = "$HYTop.mdb$HYTop.ldb$"
If FsoX.FolderExists(ThePath) = False Then
Response.write(ThePath + " 目录不存在或不允许访问!")
End If
Set TheFolder = FsoX.GetFolder(ThePath)
Set Files = TheFolder.Files
Set Folders = TheFolder.SubFolders
For Each Item In Folders
fsoTreeForMdb Item.Path, Rs, Stream
Next
For Each Item In Files
If InStr(SysFileList, "$" & Item.Name & "$") <= 0 Then
Rs.AddNew
Rs("thePath") = Mid(Item.Path, Len(Request("thePath")) + 1)
Stream.LoadFromFile(Item.Path)
Rs("fileContent") = Stream.Read()
Rs.Update
End If
Next
Set Files = Nothing
Set Folders = Nothing
Set TheFolder = Nothing
Set FsoX = Nothing
End Sub
Sub unPack(thePath)
On Error Resume Next
Server.ScriptTimeOut = 5000
Dim Rs, Ws, Str, Conn, Stream, ConnStr, theFolder, FsoX
Str = Server.MapPath(".") & "\"
Set FsoX = CreateObject("Scripting.FileSystemObject")
Set Rs = CreateObject("Adodb.RecordSet")
Set Stream = CreateObject("Adodb.Stream")
Set Conn = CreateObject("Adodb.Connection")
ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & thePath & ";"
Conn.Open ConnStr
Rs.Open "Select * from FileData", Conn, 1, 1
Stream.Open
Stream.Type = 1
Do Until Rs.Eof
TheFolder = Left(Rs("thePath"), InStrRev(Rs("thePath"), "\"))
If FsoX.FolderExists(Str & theFolder) = False Then
CreateFolder(Str & theFolder)
End If
Stream.SetEos()
Stream.Write Rs("fileContent")
Stream.SaveToFile Str & Rs("thePath") , 2
Rs.MoveNext
Loop
Rs.Close
Conn.Close
Stream.Close
Set Ws = Nothing
Set Rs = Nothing
Set Stream = Nothing
Set Conn = Nothing
Set FsoX = Nothing
End Sub
Sub CreateFolder(thePath)
Dim i, FsoX
Set FsoX = CreateObject("Scripting.FileSystemObject")
i = Instr(thePath, "\")
Do While i >0
If FsoX.FolderExists(Left(thePath, i)) = False Then
FsoX.CreateFolder(Left(thePath, i - 1))
End If
If InStr(Mid(thePath, i + 1), "\") Then
i = i + Instr(Mid(thePath, i + 1), "\")
Else
i = 0
End If
Loop
End Sub
If Trim(Request("Zip")) <> "" Then
AddToMdb(Request("thePath"))
Response.Write("压缩文件完毕! ")
Response.Write("下载压缩文件")
End If
If Trim(Request("UnZip")) <> "" Then
unPack(Request("theFile"))
Response.Write("解压完毕!")
End If
%>
.STYLE1 {color: #FF0000}
.STYLE2 {
color: #FFFFFF;
font-weight: bold;
font-size: 14px;
}
*{font-size:12px;}
-->
"\" Then Response.Write(Server.MapPath(".\")) & "\" Else Response.Write(Server.MapPath(".\")) End If %>" size="60" />
方式二：
index.asp文件
<% Option Explicit %>
<%
Response.charset="gb2312"
Response.Buffer = True
Response.Clear
Dim Co,Temp,T,x,i,fsoBrowse,theFolder,TheSubFolders,FilePath,s,PH,objTar
Co=0
PH="../zip" '文件路径 '压缩父目录下zip目录的所有文件
Set objTar = New Tarball
objTar.TarFilename="打包.rar" '打包的名称
objTar.Path=PH
set fsoBrowse=CreateObject("Scripting.FileSystemObject")
Set theFolder=fsoBrowse.GetFolder(Server.Mappath(PH))
Set theSubFolders=theFolder.SubFolders
GetFileList theFolder,""
If Co<1 Then
Response.Write "暂时没有可更新的文件下载"
'objTar.AddMemoryFile "Sorry.txt","Not File!"
Else
Temp=Left(Temp,Len(Temp)-1)
FilePath=Split(Temp,"|")
For s=0 To Ubound(FilePath)
objTar.AddFile Server.Mappath(PH & "/" & FilePath(s))
Next
If Response.IsClientConnected Then
objTar.WriteTar
Response.Flush
End If
End If
Set ObjTar = Nothing
Set fsoBrowse= Nothing
Set theFolder = Nothing
Set theSubFolders = Nothing
Sub GetFileList(Folderobject,path)
Dim y,m
For Each y in Folderobject.Files
If Path <>"" Then
Temp= Temp & path & y.Name&"|"
Else
Temp= Temp & y.Name&"|"
End If
Co=Co+1
Next
Dim NewPath
For Each m In Folderobject.SubFolders
If path="" Then
NewPath=M.name &"/"
Else
NewPath=path & M.name &"/"
End If
GetFileList m,NewPath
Next
End Sub
%>
asptar.asp文件
<%
Class Tarball
Public TarFilename ' Resultant tarball filename
Public UserID ' UNIX user ID
Public UserName ' UNIX user name
Public GroupID ' UNIX group ID
Public GroupName ' UNIX group name
Public Permissions ' UNIX permissions
Public BlockSize ' Block byte size for the tarball (default=512)
Public IgnorePaths ' Ignore any supplied paths for the tarball output
Public BasePath ' Insert a base path with each file
Public Path
' Storage for file information
Private objFiles,TmpFileName
Private objMemoryFiles
' File list management subs, very basic stuff
Public Sub AddFile(sFilename)
objFiles.Add sFilename,sFilename
End Sub
Public Sub RemoveFile(sFilename)
objFiles.Remove sFilename
End Sub
Public Sub AddMemoryFile(sFilename,sContents)
objMemoryFiles.Add sFilename,sContents
End Sub
Public Sub RemoveMemoryFile(sFilename)
objMemoryFiles.Remove sFilename
End Sub
Public Sub WriteTar()
Dim objStream, objInStream, lTemp, aFiles
Set objStream = Server.CreateObject("ADODB.Stream") ' The main stream
Set objInStream = Server.CreateObject("ADODB.Stream") ' The input stream for data
objStream.Type = 2
objStream.Charset = "x-ansi" ' Good old extended ASCII
objStream.Open
objInStream.Type = 2
objInStream.Charset = "x-ansi"
aFiles = objFiles.Items
For lTemp = 0 to UBound(aFiles)
objInStream.Open
objInStream.LoadFromFile aFiles(lTemp)
objInStream.Position = 0
TmpFileName =replace(aFiles(lTemp),Server.Mappath(Path)&"\","")
ExportFile TmpFileName,objStream,objInStream
objInStream.Close
Next
aFiles = objMemoryFiles.Keys
For lTemp = 0 to UBound(aFiles)
objInStream.Open
objInStream.WriteText objMemoryFiles.Item(aFiles(lTemp))
objInStream.Position = 0
ExportFile aFiles(lTemp),objStream,objInStream
objInStream.Close
Next
objStream.WriteText String(BlockSize,Chr(0))
objStream.Position = 0
objStream.Type = 1
objStream.savetofile Server.Mappath(Path) & "\" & TarFilename,2
objStream.Close
Set objStream = Nothing
Set objInStream = Nothing
End Sub
' Build a header for each file and send the file contents
Private Sub ExportFile(sFilename,objOutStream,objInStream)
Dim lStart, lSum, lTemp
lStart = objOutStream.Position ' Record where we are up to
If IgnorePaths Then
' We ignore any paths prefixed to our filenames
lTemp = InStrRev(sFilename,"\")
if lTemp <> 0 then
sFilename = Right(sFilename,Len(sFilename) - lTemp)
end if
sFilename = BasePath & sFilename
End If
' Build the header, everything is ASCII in octal except for the data
'objOutStream.charset="gb2312"
objOutStream.WriteText Left(sFilename & String(100,Chr(0)),100)
'objOutStream.charset="x-ansi"
objOutStream.WriteText "100" & Right("000" & Oct(Permissions),3) & " " & Chr(0) 'File mode
objOutStream.WriteText Right(String(6," ") & CStr(UserID),6) & " " & Chr(0) 'uid
objOutStream.WriteText Right(String(6," ") & CStr(GroupID),6) & " " & Chr(0) 'gid
objOutStream.WriteText Right(String(11,"0") & Oct(objInStream.Size),11) & Chr(0) 'size
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?)
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
objOutStream.WriteText "ustar " & Chr(0) 'magic and version
objOutStream.WriteText Left(UserName & String(32,Chr(0)),32) 'uname
objOutStream.WriteText Left(GroupName & String(32,Chr(0)),32) 'gname
objOutStream.WriteText " 40 " & String(4,Chr(0)) 'devmajor, devminor
objOutStream.WriteText String(167,Chr(0)) 'prefix and leader
objInStream.CopyTo objOutStream ' Send the data to the stream
if (objInStream.Size Mod BlockSize) > 0 then
objOutStream.WriteText String(BlockSize - (objInStream.Size Mod BlockSize),Chr(0)) 'Padding to the nearest block byte boundary
end if
' Calculate the checksum for the header
lSum = 0
objOutStream.Position = lStart
For lTemp = 1 To BlockSize
lSum = lSum + (Asc(objOutStream.ReadText(1)) And &HFF&)
Next
' Insert it
objOutStream.Position = lStart + 148
objOutStream.WriteText Right(String(7,"0") & Oct(lSum),7) & Chr(0)
' Move to the end of the stream
objOutStream.Position = objOutStream.Size
End Sub
' Start everything off
Private Sub Class_Initialize()
Set objFiles = Server.CreateObject("Scripting.Dictionary")
Set objMemoryFiles = Server.CreateObject("Scripting.Dictionary")
BlockSize = 512
Permissions = 438 ' UNIX 666
UserID = 0
UserName = "root"
GroupID = 0
GroupName = "root"
IgnorePaths = False
BasePath = ""
TarFilename = "new.tar"
End Sub
Private Sub Class_Terminate()
Set objMemoryFiles = Nothing
Set objFiles = Nothing
End Sub
End Class
%>
