asp打包类

答案：<% 
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>

上一个：数组显示菜单效果
下一个：aspjpeg 添加水印教程及生成缩略图教程