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(rootpatharrFile(1)) Then fso.CreateFolder(rootpatharrFile(1)) End If ElseIf arrFile(0) >= 0 Then If fso.FileExists(rootpatharrFile(1)) Then fso.DeleteFile(rootpatharrFile(1)) End If s1.Position = 0 buf = s.Read(arrFile(0)) If Not IsNull(buf) Then s1.Write(buf) s1.SetEOS s1.SaveToFile(rootpatharrFile(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>
