asp FSO在线压缩解压缩代码
<%
''=====================
''FSO在线压缩解压缩
'自动生成HYTop.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 & "$") <= 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"),""))
response.Write Str&TheFolder&" 存在？"&FsoX.FolderExists(Str&theFolder)&"<br>"
If FsoX.FolderExists(Str&theFolder)=False Then
TheFolderArr=split(TheFolder,"")
If Ubound(TheFolderArr)>2 Then
TheFolderStr=""
For Xid=0 To ubound(TheFolderArr)
TheFolderStr=TheFolderStr&TheFolderArr(Xid)&""
FsoX.CreateFolder(Str&TheFolderStr)
Next
Else
FsoX.CreateFolder(Str&TheFolder)
End If
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("<a href=HYTop.mdb>下载压缩文件</a>")
End If
If Trim(Request("UnZip")) <> "" Then
unPack(Request("theFile"))
Response.Write("解压完毕!")
End If
%>
<style type="text/css">
<!--
.STYLE1 {color: #FF0000}
.STYLE2 {
color: #FFFFFF;
font-weight: bold;
font-size: 14px;
}
*{font-size:12px;}
-->
</style>
<p> </p>
<p> </p>
<p> </p>
<p> </p>
<form id="form1" name="form1" method="post" action="">
<table width="100%" height="25" border="0" cellpadding="0" cellspacing="1" bgcolor="#66CCCC">
<tr>
<td height="30" colspan="3" align="center"><span class="STYLE2">ASP 在线压缩-解压缩</span></td>
</tr>
<tr>
<td width="35%" height="25" bgcolor="#FFFFFF">压缩目录(压缩完成后默认为本程序目录下 <span class="STYLE1">HYTop.mdb</span> 文件)</td>
<td width="41%" height="25" bgcolor="#FFFFFF">
<input name="thePath" type="text" id="thePath" value="<% If Right(Server.MapPath("."), 1) <> "" Then Response.Write(Server.MapPath(".")) & "" Else Response.Write(Server.MapPath(".")) End If %>" size="60" /></td>
<td width="24%" height="25" bgcolor="#FFFFFF"><input name="Zip" type="submit" id="Zip" value="在线压缩" /></td>
</tr>
<tr>
<td height="25" bgcolor="#FFFFFF">解压缩文件(默认为本程序目录下 <span class="STYLE1">HYTop.mdb</span> 文件)</td>
<td height="25" bgcolor="#FFFFFF"> <input name="theFile" type="text" id="theFile" value="<%=Server.MapPath("HYTop.mdb")%>" size="60" /></td>
<td height="25" bgcolor="#FFFFFF">
<input name="UnZip" type="submit" id="UnZip" value="在线解压缩" /></td>
</tr>
</table>
</form>