<%
OnErrorResumeNext
Dimr
Setr=NewRar

r.AddServer.MapPath("a.gIf")
r.AddServer.MapPath("a.txt")
r.AddServer.MapPath("test")
r.AddServer.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)
Setr=Nothing
%>
<scriptLanguage="Vbscript"Runat="server">
'-----------------------------------------------------
'描述:Asp打包类
'作者:小灰(quxiaohui_0@163.com)
'链接:http://asp2004.nethttp://blog.csdn.net/iuhxqhttp://bbs.asp2004.net
'版本:1.0Beta
'版权:本作品可免费使用，但是请勿移除版权信息
'-----------------------------------------------------
ClassRar
Dimfiles,packname,s,s1,s2,rootpath,fso,f,buf
PrivateSubClass_Initialize
Randomize
DimranNum
ranNum=Int(90000*Rnd)+10000
packname=Year(Now)&Month(Now)&Day(Now)&Hour(Now)&Minute(Now)&Second(Now)&ranNum&".asp2004"

rootpath=Server.MapPath("./")

Setfiles=server.CreateObject("Scripting.Dictionary")
Setfso=Server.CreateObject("Scripting.FileSystemObject")

Sets=server.CreateObject("ADODB.Stream"):s.Open:s.Type=1
Sets1=server.CreateObject("ADODB.Stream"):s1.Open:s1.Type=1
Sets2=server.CreateObject("ADODB.Stream"):s2.Open:s2.Type=2
EndSub

PrivateSubClass_Terminate
s.Close:Sets=Nothing
s1.Close:Sets1=Nothing
s2.Close:Sets2=Nothing

Setfso=Nothing
EndSub

PublicSubAdd(obj)
Iffso.FileExists(obj)Then
Setf=fso.GetFile(obj)
files.Addobj,f.Size
ElseIffso.FolderExists(obj)Then
files.Addobj,-1
Setf=fso.GetFolder(obj)
Setfc=f.Files
ForEachf1infc
Add(LCase(f1.Path))
Next
EndIf
EndSub

PublicSubPack
Dimstr
a=files.Keys
b=files.Items
fori=0tofiles.count-1
Ifb(i)>=0Then
s.LoadFromFile(a(i))
buf=s.Read
IfNotIsNull(buf)Thens1.Write(buf)
EndIf
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.Writebuf
s1.Position=0
s.Writes1.Read
s.SetEOS
s.SaveToFile(packname)
EndSub

PublicSubUnPack

IfNotfso.FolderExists(rootpath)Then
fso.CreateFolder(rootpath)
EndIf
Dimsize
'转换文件大小
s.LoadFromFile(packname)
size=CInt(StreamToText(s.Read(10)))
str=StreamToText(s.Read(size))
arr=Split(str,vbCrLf)

fori=0toUbound(arr)-1
arrFile=Split(arr(i),">")
IfarrFile(0)<0Then
IfNotfso.FolderExists(rootpath&arrFile(1))Then
fso.CreateFolder(rootpath&arrFile(1))
EndIf
ElseIfarrFile(0)>=0Then
Iffso.FileExists(rootpath&arrFile(1))Then
fso.DeleteFile(rootpath&arrFile(1))
EndIf
s1.Position=0
buf=s.Read(arrFile(0))
IfNotIsNull(buf)Thens1.Write(buf)
s1.SetEOS
s1.SaveToFile(rootpath&arrFile(1))
EndIf
Next
EndSub

PublicFunctionStreamToText(stream)
IfIsNull(stream)Then
StreamToText=""
Else
Setsm=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:Setsm=Nothing
EndIf
EndFunction

PublicFunctionTextToStream(text)
Iftext=""Then
TextToStream=""'这里该如何写？空流？
Else
Setsm=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:Setsm=Nothing
EndIf
EndFunction
EndClass
</script>