asp打包类
网络编程 2021-07-05 10:58www.168986.cn编程入门
<%
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.)
' 链接: http://asp2004. http://blog.csdn./iuhxq http://bbs.asp2004.
' 版本: 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>
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.)
' 链接: http://asp2004. http://blog.csdn./iuhxq http://bbs.asp2004.
' 版本: 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>
上一篇:显示在线人数
下一篇:生成静态页大全[ASP/PHP/ASPX]
编程语言
- 机械手焊接机器人编程 机械手焊接设备编程
- vb数据库编程实例,vb做数据库
- tiobe世界编程语言排行榜,全球编程语言排行
- 成都java编程培训 成都it编程培训中心
- 编程基础培训,编程基础知识培训
- flash游戏编程基础教程,flash游戏开发教程
- 不会英语能学编程吗 不会英语可以学程序员吗
- 爱心代码编程C语言 爱心代码编程c语言公式
- c语言编程学习入门 c语言编程快速入门
- 西门子plc编程培训 西门子plc编程培训班
- 哪里可以学编程 台州哪里可以学编程
- 少儿编程哪个好 少儿编程哪个品牌好
- 编程是什么意思,图形编程是什么意思
- c语言编程软件下载,c语言编程软件在哪下载
- java编程软件下载,java编程下载手机版
- ug编程培训学校,ug编程培训教程