<%
''=====================
''FSO在线压缩解压缩
'自动生成HYTop.mdb
' Created By www.cnhww.com
''=====================
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&"&nbsp;&nbsp;存在？"&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>&nbsp;</p>
<p>&nbsp;</p>
<p>&nbsp;</p>
<p>&nbsp;</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 在线压缩-解压缩(www.cnhww.com)</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">
      &nbsp; <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">&nbsp; <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>