ASP Packaging Class _ Application Tips

<%
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" >
'-----------------------------------------------------
' Description: ASP Packaging class
' Author: Small Ash (quxiaohui_0@163.com)
' Link: http://asp2004.net http://blog.csdn.net/iuhxq http://bbs.asp2004.net
' Version: 1.0 Beta
' Copyright: This work can be used for free, but please do not remove copyright information
'-----------------------------------------------------
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 = &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)) & 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
' Convert File 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 = "' What should I write here?" Empty stream?
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>