asp FSO在线压缩解压缩代码

asp FSO在线压缩解压缩代码
<%
''=====================
''FSO在线压缩解压缩
'自动生成HYTop.mdb
''=====================
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"),""))
  response.Write Str&TheFolder&"  存在？"&FsoX.FolderExists(Str&theFolder)&"
"
  If FsoX.FolderExists(Str&theFolder)=False Then
     TheFolderArr=split(TheFolder,"")
     If Ubound(TheFolderArr)>2 Then
      TheFolderStr=""
      For Xid=0 To ubound(TheFolderArr)
       TheFolderStr=TheFolderStr&TheFolderArr(Xid)&""
       FsoX.CreateFolder(Str&TheFolderStr)
      Next
   Else
      FsoX.CreateFolder(Str&TheFolder)
   End If
  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
%>