<% On Error Resume Next Dim r Set r = New Rar r.Add Server.MapPath("a.gIf") r.Add Server.MapPath("a.txt") r.Add Server.MapPath("test") r.Add Server.MapPath("file.asp") r.packname = Server.MapPath("xxx.dat") r.Pack r.rootpath = Server.MapPath("xxx") r.packname = Server.MapPath("xxx.dat") r.UnPack Response.Write(Err.Description) Set r = Nothing %> <script Language="Vbscript" Runat="server"> '----------------------------------------------------- ' 描述: Asp打包类 ' 作者: 小灰(quxiaohui_0@163.com) ' 链接: http://asp2004.net http://blog.csdn.net/iuhxq http://bbs.asp2004.net ' 版本: 1.0 Beta ' 版权: 本作品可免费使用，但是请勿移除版权信息 '----------------------------------------------------- Class Rar  Dim files,packname,s,s1,s2,rootpath,fso,f,buf  Private Sub Class_Initialize  Randomize  Dim ranNum  ranNum = Int(90000 * Rnd) + 10000  packname = Year(Now)&Month(Now)&Day(Now)&Hour(Now)&Minute(Now)&Second(Now)&ranNum&".asp2004"  rootpath = Server.MapPath("./")  Set files = server.CreateObject("Scripting.Dictionary")  Set fso = Server.CreateObject("Scripting.FileSystemObject")  Set s = server.CreateObject("ADODB.Stream"):s.Open:s.Type = 1  Set s1 = server.CreateObject("ADODB.Stream"):s1.Open:s1.Type = 1  Set s2 = server.CreateObject("ADODB.Stream"):s2.Open:s2.Type = 2  End Sub  Private Sub Class_Terminate  s.Close:Set s = Nothing  s1.Close:Set s1 = Nothing  s2.Close:Set s2 = Nothing  Set fso = Nothing  End Sub  Public Sub Add(obj)  If fso.FileExists(obj) Then  Set f = fso.GetFile(obj)  files.Add obj,f.Size  ElseIf fso.FolderExists(obj) Then  files.Add obj,-1  Set f = fso.GetFolder(obj)  Set fc = f.Files  For Each f1 in fc  Add(LCase(f1.Path))  Next  End If  End Sub  Public Sub Pack  Dim str  a = files.Keys  b = files.Items  for i=0 to files.count-1  If b(i)>=0 Then  s.LoadFromFile(a(i))  buf = s.Read  If Not IsNull(buf) Then s1.Write(buf)  End If  str = str & b(i)&">"&Replace(a(i),rootpath,"")&vbCrLf  next  str = CStr(Right("000000000"&len(str),10)) & str  buf = TextToStream(str)  s.Position = 0  s.Write buf  s1.Position = 0  s.Write s1.Read  s.SetEOS  s.SaveToFile(packname)  End Sub  Public Sub UnPack  If Not fso.FolderExists(rootpath) Then  fso.CreateFolder(rootpath)  End If  Dim size  '转换文件大小  s.LoadFromFile(packname)  size = CInt(StreamToText(s.Read(10)))  str = StreamToText(s.Read(size))  arr = Split(str,vbCrLf)  for i=0 to Ubound(arr)-1  arrFile = Split(arr(i),">")  If arrFile(0) < 0 Then  If Not fso.FolderExists(rootpath&arrFile(1)) Then  fso.CreateFolder(rootpath&arrFile(1))  End If  ElseIf arrFile(0) >= 0 Then  If fso.FileExists(rootpath&arrFile(1)) Then  fso.DeleteFile(rootpath&arrFile(1))  End If  s1.Position = 0  buf = s.Read(arrFile(0))  If Not IsNull(buf) Then s1.Write(buf)  s1.SetEOS  s1.SaveToFile(rootpath&arrFile(1))  End If  Next  End Sub  Public Function StreamToText(stream)  If IsNull(stream) Then  StreamToText = ""  Else  Set sm = server.CreateObject("ADODB.Stream"):sm.Open:sm.Type = 1  sm.Write(stream)  sm.Position = 0  sm.Type = 2  sm.charset = "gb2312"  sm.Position = 0  StreamToText = sm.ReadText()  sm.Close:Set sm = Nothing  End If  End Function  Public Function TextToStream(text)  If text="" Then  TextToStream = "" '这里该如何写？空流？  Else  Set sm = server.CreateObject("ADODB.Stream"):sm.Open:sm.Type = 2:sm.charset = "gb2312"  sm.WriteText(text)  sm.Position = 0  sm.Type = 1  sm.Position = 0  TextToStream = sm.Read  sm.Close:Set sm = Nothing  End If  End Function End Class </script>