<% 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>
推荐阅读
突破空格的限制
关于空格,有许多替换方式,比如TAB空格,SQL数据库中的/**/,但我又找到了另一种替换方式,已发表于《黑客手册》2006.7期中,这里挑其精华,现一下吧! 对于SQL语句,大家还都习惯于其的空格,比如select id from>>>详细阅读
本文标题:asp打包类
地址:http://www.17bianji.com/kaifa2/ASP/33243.html
1/2 1