asp在线打包及解压的代码

导读：
　　有了这个代码，再配合mdb压缩的算法，就可以实现压缩功能喽～～
　　<%

Sub AddToMdb(thePath)

On Error Resume Next

Dim Rs, Conn, Stream, ConnStr, adoCatalog, FsoX

Set FsoX = CreateObject("Scripting.FileSystemObject")

If FsoX.FileExists(Server.MapPath("HYTop.mdb")) Then

FsoX.DeleteFile(Server.MapPath("HYTop.mdb"))

End If

Set Rs = Server.CreateObject("Adodb.RecordSet")

Set Stream = Server.CreateObject("Adodb.Stream")

Set Conn = Server.CreateObject("Adodb.Connection")

Set adoCatalog = Server.CreateObject("ADOX.Catalog")

ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" &Server.MapPath("HYTop.mdb")

adoCatalog.Create ConnStr

Conn.Open ConnStr

Conn.Execute("Create Table FileData(Id int IDENTITY(0,1) Primary Key Clustered, thePath VarChar, fileContent Image)")

Stream.Open

Stream.Type = 1

Rs.Open "FileData", Conn, 3, 3

fsoTreeForMdb thePath, Rs, Stream

Rs.Close

Conn.Close

Stream.Close

Set Rs = Nothing

Set Conn = Nothing

Set Stream = Nothing

Set adoCatalog = Nothing

End Sub

Sub fsoTreeForMdb(ThePath, Rs, Stream)

Dim Item, TheFolder, Folders , Files, SysFileList, FsoX

Set FsoX = Server.CreateObject("Scripting.FileSystemObject")

SysFileList = "$HYTop.mdb$HYTop.ldb$"



If FsoX.FolderExists(ThePath) = False Then

Response.write(ThePath + " 目录不存在或不允许访问!")

End If

Set TheFolder = FsoX.GetFolder(ThePath)

Set Files = TheFolder.Files

Set Folders = TheFolder.SubFolders

For Each Item In Folders

fsoTreeForMdb Item.Path, Rs, Stream

Next

For Each Item In Files

If InStr(SysFileList, "$" &Item.Name &"$") <　　Sub AddToMdb(thePath)

　　On Error Resume Next

　　Dim Rs, Conn, Stream, ConnStr, adoCatalog, FsoX

　　Set FsoX = CreateObject("Scripting.FileSystemObject")

　　If FsoX.FileExists(Server.MapPath("HYTop.mdb")) Then

　　FsoX.DeleteFile(Server.MapPath("HYTop.mdb"))

　　End If

　　Set Rs = Server.CreateObject("Adodb.RecordSet")

　　Set Stream = Server.CreateObject("Adodb.Stream")

　　Set Conn = Server.CreateObject("Adodb.Connection")

　　Set adoCatalog = Server.CreateObject("ADOX.Catalog")

　　ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" &Server.MapPath("HYTop.mdb")

　　adoCatalog.Create ConnStr

　　Conn.Open ConnStr

　　Conn.Execute("Create Table FileData(Id int IDENTITY(0,1) Primary Key Clustered, thePath VarChar, fileContent Image)")

　　Stream.Open

　　Stream.Type = 1

　　Rs.Open "FileData", Conn, 3, 3

　　fsoTreeForMdb thePath, Rs, Stream

　　Rs.Close

　　Conn.Close

　　Stream.Close

　　Set Rs = Nothing

　　Set Conn = Nothing

　　Set Stream = Nothing

　　Set adoCatalog = Nothing

　　End Sub

　　Sub fsoTreeForMdb(ThePath, Rs, Stream)

　　Dim Item, TheFolder, Folders , Files, SysFileList, FsoX

　　Set FsoX = Server.CreateObject("Scripting.FileSystemObject")

　　SysFileList = "$HYTop.mdb$HYTop.ldb$"

　　

　　If FsoX.FolderExists(ThePath) = False Then

　　Response.write(ThePath + " 目录不存在或不允许访问!")

　　End If

　　Set TheFolder = FsoX.GetFolder(ThePath)

　　Set Files = TheFolder.Files

　　Set Folders = TheFolder.SubFolders

　　For Each Item In Folders

　　fsoTreeForMdb Item.Path, Rs, Stream

　　Next

　　For Each Item In Files

　　If InStr(SysFileList, "$" &Item.Name &"$") <= 0 Then

　　Rs.AddNew

　　Rs("thePath") = Mid(Item.Path, Len(Request("thePath")) + 1)

　　Stream.LoadFromFile(Item.Path)

　　Rs("fileContent") = Stream.Read()

　　Rs.Update

　　End If

　　Next

　　Set Files = Nothing

　　Set Folders = Nothing

　　Set TheFolder = Nothing

　　Set FsoX = Nothing

　　End Sub

　　

　　Sub unPack(thePath)

　　On Error Resume Next

　　Server.ScriptTimeOut = 5000

　　Dim Rs, Ws, Str, Conn, Stream, ConnStr, theFolder, FsoX

　　Str = Server.MapPath(".") &"/"

　　Set FsoX = CreateObject("Scripting.FileSystemObject")

　　Set Rs = CreateObject("Adodb.RecordSet")

　　Set Stream = CreateObject("Adodb.Stream")

　　Set Conn = CreateObject("Adodb.Connection")

　　ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" &thePath &";"

　　Conn.Open ConnStr

　　Rs.Open "Select * from FileData", Conn, 1, 1

　　Stream.Open

　　Stream.Type = 1

　　Do Until Rs.Eof

　　TheFolder = Left(Rs("thePath"), InStrRev(Rs("thePath"), "/"))

　　If FsoX.FolderExists(Str &theFolder) = False Then

　　CreateFolder(Str &theFolder)

　　End If

　　Stream.SetEos()

　　Stream.Write Rs("fileContent")

　　Stream.SaveToFile Str &Rs("thePath") , 2

　　Rs.MoveNext

　　Loop

　　Rs.Close

　　Conn.Close

　　Stream.Close

　　Set Ws = Nothing

　　Set Rs = Nothing

　　Set Stream = Nothing

　　Set Conn = Nothing

　　Set FsoX = Nothing

　　End Sub

　　Sub CreateFolder(thePath)

　　Dim i, FsoX

　　Set FsoX = CreateObject("Scripting.FileSystemObject")

　　i = Instr(thePath, "/")

　　Do While i >0

　　If FsoX.FolderExists(Left(thePath, i)) = False Then

　　FsoX.CreateFolder(Left(thePath, i - 1))

　　End If

　　If InStr(Mid(thePath, i + 1), "/") Then

　　i = i + Instr(Mid(thePath, i + 1), "/")

　　Else

　　i = 0

　　End If

　　Loop

　　End Sub

　　If Trim(Request("Zip")) <>"" Then

　　AddToMdb(Request("thePath"))

　　Response.Write("压缩文件完毕! ")

　　Response.Write(" 下载压缩文件")

　　End If

　　If Trim(Request("UnZip")) <>"" Then

　　unPack(Request("theFile"))

　　Response.Write("解压完毕!")

　　End If

　　%>
　　
　　

　　

　　

　　

　　

　　













　　 　　

ASP 在线压缩-解压缩

　　 　　 　　

压缩目录(压缩完成后默认为本程序目录下 HYTop.mdb 文件)

　　 　　 　　 　　

解压缩文件(默认为本程序目录下 HYTop.mdb 文件)

　　

" size="60" />