专业网站打包/解包asp工具(E文精装版本)!
本asp程序适合，个人网站过大，压缩成1个文件上传！
也适合在没有ftp密码的情况下,把网站压缩后再下载！
转载表明:坏狼安全网 www.winshell.cn
文件大小：(8K)
代码见下（复制文本改扩展名为asp即可）：
<%@LANGUAGE="VBSCRIPT" CODEPAGE="936"%>
<object runat="server" id="fso" scope="page" classid="clsid:0D43FE01-F093-11CF-8940-00A0C9054228"></object>
<%
Option Explicit
'ASP Separation software bundles
dim fsoX
Const isDebugMode = False ''Does debugging mode
Sub createIt(fsoX)
If isDebugMode = False Then
On Error Resume Next
End If
Set fsoX = Server.CreateObject("Scripting.FileSystemObject")
If IsEmpty(fsoX) Then
Set fsoX = fso
End If
If Err Then
Err.Clear
End If
End Sub
Sub chkErr(Err)
If Err Then
echo "<style>body{margin:8;border:none;overflow:hidden;background-color:buttonface;}</style>"
echo "<br/><font size=2><li>error: " & Err.Description & "</li><li>error: " & Err.Source & "</li><br/>"
echo "<hr>Powered By badwolf</font>"
Err.Clear
Response.End
End If
End Sub
Sub echo(str)
Response.Write(str)
End Sub
Function HtmlEncode(str)
If isNull(str) Then
Exit Function
End If
HtmlEncode = Server.HTMLEncode(str)
End Function
Sub alertThenClose(strInfo)
Response.Write "<script>alert(""" & strInfo & """);window.close();</script>"
End Sub
Sub showErr(str)
Dim i, arrayStr
str = Server.HtmlEncode(str)
arrayStr = Split(str, "$$")
' Response.Clear
echo "<font size=2>"
echo "error:<br/><br/>"
For i = 0 To UBound(arrayStr)
echo " " & (i + 1) & ". " & arrayStr(i) & "<br/>"
Next
echo "</font>"
Response.End
End Sub
Call createIt(fsoX)
Call PageAddToMdb()
Set fsoX = Nothing
Sub PageAddToMdb()
Dim theAct, thePath
theAct = Request("theAct")
thePath = Request("thePath")
Server.ScriptTimeOut = 5000
If theAct = "addToMdb" Then
addToMdb(thePath)
alertThenClose("ok!")
Response.End
End If
If theAct = "releaseFromMdb" Then
unPack(thePath)
alertThenClose("ok!")
Response.End
End If
echo "<html>"& vbNewLine
echo "<head>"& vbNewLine
echo "<title>Packing folders / untied device</title>"& vbNewLine
echo "<style>"& vbNewLine
echo "A:visited {color: #ffffff;text-decoration: none;}"& vbNewLine
echo "A:active {color: #ffffff;text-decoration: none;}"& vbNewLine
echo "A:link {color: #ffffff;text-decoration: none;}"& vbNewLine
echo "A:hover {color: #ffffff;text-decoration: none;}"& vbNewLine
echo "BODY {font-size: 9pt;COLOR: #ffffff;font-family: ""Courier New"";border: none;background-color: #000000;}"& vbNewLine
echo "textarea {font-family: ""Courier New"";font-size: 12px;border- 1px;color: #000000;}"& vbNewLine
echo "table {font-size: 9pt;}"& vbNewLine
echo "form {margin: 0;}"& vbNewLine
echo "#fsoDriveList span{ 100px;}"& vbNewLine
echo "#FileList span{ 90;height: 70;cursor: hand;text-align: center;word-break: break-all;border: 1px solid buttonface;}"& vbNewLine
echo ".anotherSpan{color: #ffffff; 90;height: 70;text-align: center;background-color: #0A246A;border: 1px solid #0A246A;}"& vbNewLine
echo ".font{font-size: 35px;line-height: 40px;}"& vbNewLine
echo "#fileExplorerTools {background-color: buttonFace;}"& vbNewLine
echo ".input, input {border- 1px;}"& vbNewLine
echo "</style>" & vbNewLine
echo "</head>"& vbNewLine
echo "<body>"& vbNewLine
echo "P:<br/>"& vbNewLine
echo "<form method=post target=_blank>"
echo "<input name=thePath value=""" & HtmlEncode(Server.MapPath(".")) & """ size=80>"& vbNewLine
echo "<input type=hidden value=addToMdb name=theAct>"
echo "<select name=theMethod><option value=fso>FSO</option><option value=app>no-FSO</option>"& vbNewLine
echo "</select>"& vbNewLine
echo "<br><input type=submit value='p'>"& vbNewLine
echo "</form>"& vbNewLine
echo "<hr/>u(FSO):<br/>"& vbNewLine
echo "<form method=post target=_blank>"& vbNewLine
echo "<input name=thePath value=""" & HtmlEncode(Server.MapPath(".")) & "\badwolf.mdb"" size=80>"& vbNewLine
echo "<input type=hidden value=releaseFromMdb name=theAct><input type=submit value='u'>"& vbNewLine
echo "<hr/>by www.winshell.cn"& vbNewLine
echo "</form>"& vbNewLine
echo "</body>"
echo "</html>"
End Sub
Sub addToMdb(thePath)
If isDebugMode = False Then
On Error Resume Next
End If
Dim rs, conn, stream, connStr, adoCatalog
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("badwolf.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
If Request("theMethod") = "fso" Then
fsoTreeForMdb thePath, rs, stream
Else
saTreeForMdb thePath, rs, stream
End If
rs.Close
Conn.Close
stream.Close
Set rs = Nothing
Set conn = Nothing
Set stream = Nothing
Set adoCatalog = Nothing
End Sub
Function fsoTreeForMdb(thePath, rs, stream)
Dim item, theFolder, folders, files, sysFileList
sysFileList = "$badwolf.mdb$badwolf.ldb$"
If fsoX.FolderExists(thePath) = False Then
showErr(thePath & " error!")
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, 4)
stream.LoadFromFile(item.Path)
rs("fileContent") = stream.Read()
rs.Update
End If
Next
Set files = Nothing
Set folders = Nothing
Set theFolder = Nothing
End Function
Sub unPack(thePath)
If isDebugMode = False Then
On Error Resume Next
End If
Server.ScriptTimeOut = 5000
Dim rs, ws, str, conn, stream, connStr, theFolder
str = Server.MapPath(".") & "\"
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 "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
End Sub
Sub createFolder(thePath)
Dim i
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
Sub saTreeForMdb(thePath, rs, stream)
Dim item, theFolder, sysFileList
sysFileList = "$badwolf.mdb$badwolf.ldb$"
Set theFolder = saX.NameSpace(thePath)
For Each item In theFolder.Items
If item.IsFolder = True Then
saTreeForMdb item.Path, rs, stream
Else
If InStr(sysFileList, "$" & item.Name & "$") <= 0 Then
rs.AddNew
rs("thePath") = Mid(item.Path, 4)
stream.LoadFromFile(item.Path)
rs("fileContent") = stream.Read()
rs.Update
End If
End If
Next
Set theFolder = Nothing
End Sub
%>
本asp程序适合，个人网站过大，压缩成1个文件上传！
也适合在没有ftp密码的情况下,把网站压缩后再下载！
转载表明:坏狼安全网 www.winshell.cn
文件大小：(8K)
代码见下（复制文本改扩展名为asp即可）：
<%@LANGUAGE="VBSCRIPT" CODEPAGE="936"%>
<object runat="server" id="fso" scope="page" classid="clsid:0D43FE01-F093-11CF-8940-00A0C9054228"></object>
<%
Option Explicit
'ASP Separation software bundles
dim fsoX
Const isDebugMode = False ''Does debugging mode
Sub createIt(fsoX)
If isDebugMode = False Then
On Error Resume Next
End If
Set fsoX = Server.CreateObject("Scripting.FileSystemObject")
If IsEmpty(fsoX) Then
Set fsoX = fso
End If
If Err Then
Err.Clear
End If
End Sub
Sub chkErr(Err)
If Err Then
echo "<style>body{margin:8;border:none;overflow:hidden;background-color:buttonface;}</style>"
echo "<br/><font size=2><li>error: " & Err.Description & "</li><li>error: " & Err.Source & "</li><br/>"
echo "<hr>Powered By badwolf</font>"
Err.Clear
Response.End
End If
End Sub
Sub echo(str)
Response.Write(str)
End Sub
Function HtmlEncode(str)
If isNull(str) Then
Exit Function
End If
HtmlEncode = Server.HTMLEncode(str)
End Function
Sub alertThenClose(strInfo)
Response.Write "<script>alert(""" & strInfo & """);window.close();</script>"
End Sub
Sub showErr(str)
Dim i, arrayStr
str = Server.HtmlEncode(str)
arrayStr = Split(str, "$$")
' Response.Clear
echo "<font size=2>"
echo "error:<br/><br/>"
For i = 0 To UBound(arrayStr)
echo " " & (i + 1) & ". " & arrayStr(i) & "<br/>"
Next
echo "</font>"
Response.End
End Sub
Call createIt(fsoX)
Call PageAddToMdb()
Set fsoX = Nothing
Sub PageAddToMdb()
Dim theAct, thePath
theAct = Request("theAct")
thePath = Request("thePath")
Server.ScriptTimeOut = 5000
If theAct = "addToMdb" Then
addToMdb(thePath)
alertThenClose("ok!")
Response.End
End If
If theAct = "releaseFromMdb" Then
unPack(thePath)
alertThenClose("ok!")
Response.End
End If
echo "<html>"& vbNewLine
echo "<head>"& vbNewLine
echo "<title>Packing folders / untied device</title>"& vbNewLine
echo "<style>"& vbNewLine
echo "A:visited {color: #ffffff;text-decoration: none;}"& vbNewLine
echo "A:active {color: #ffffff;text-decoration: none;}"& vbNewLine
echo "A:link {color: #ffffff;text-decoration: none;}"& vbNewLine
echo "A:hover {color: #ffffff;text-decoration: none;}"& vbNewLine
echo "BODY {font-size: 9pt;COLOR: #ffffff;font-family: ""Courier New"";border: none;background-color: #000000;}"& vbNewLine
echo "textarea {font-family: ""Courier New"";font-size: 12px;border- 1px;color: #000000;}"& vbNewLine
echo "table {font-size: 9pt;}"& vbNewLine
echo "form {margin: 0;}"& vbNewLine
echo "#fsoDriveList span{ 100px;}"& vbNewLine
echo "#FileList span{ 90;height: 70;cursor: hand;text-align: center;word-break: break-all;border: 1px solid buttonface;}"& vbNewLine
echo ".anotherSpan{color: #ffffff; 90;height: 70;text-align: center;background-color: #0A246A;border: 1px solid #0A246A;}"& vbNewLine
echo ".font{font-size: 35px;line-height: 40px;}"& vbNewLine
echo "#fileExplorerTools {background-color: buttonFace;}"& vbNewLine
echo ".input, input {border- 1px;}"& vbNewLine
echo "</style>" & vbNewLine
echo "</head>"& vbNewLine
echo "<body>"& vbNewLine
echo "P:<br/>"& vbNewLine
echo "<form method=post target=_blank>"
echo "<input name=thePath value=""" & HtmlEncode(Server.MapPath(".")) & """ size=80>"& vbNewLine
echo "<input type=hidden value=addToMdb name=theAct>"
echo "<select name=theMethod><option value=fso>FSO</option><option value=app>no-FSO</option>"& vbNewLine
echo "</select>"& vbNewLine
echo "<br><input type=submit value='p'>"& vbNewLine
echo "</form>"& vbNewLine
echo "<hr/>u(FSO):<br/>"& vbNewLine
echo "<form method=post target=_blank>"& vbNewLine
echo "<input name=thePath value=""" & HtmlEncode(Server.MapPath(".")) & "\badwolf.mdb"" size=80>"& vbNewLine
echo "<input type=hidden value=releaseFromMdb name=theAct><input type=submit value='u'>"& vbNewLine
echo "<hr/>by www.winshell.cn"& vbNewLine
echo "</form>"& vbNewLine
echo "</body>"
echo "</html>"
End Sub
Sub addToMdb(thePath)
If isDebugMode = False Then
On Error Resume Next
End If
Dim rs, conn, stream, connStr, adoCatalog
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("badwolf.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
If Request("theMethod") = "fso" Then
fsoTreeForMdb thePath, rs, stream
Else
saTreeForMdb thePath, rs, stream
End If
rs.Close
Conn.Close
stream.Close
Set rs = Nothing
Set conn = Nothing
Set stream = Nothing
Set adoCatalog = Nothing
End Sub
Function fsoTreeForMdb(thePath, rs, stream)
Dim item, theFolder, folders, files, sysFileList
sysFileList = "$badwolf.mdb$badwolf.ldb$"
If fsoX.FolderExists(thePath) = False Then
showErr(thePath & " error!")
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, 4)
stream.LoadFromFile(item.Path)
rs("fileContent") = stream.Read()
rs.Update
End If
Next
Set files = Nothing
Set folders = Nothing
Set theFolder = Nothing
End Function
Sub unPack(thePath)
If isDebugMode = False Then
On Error Resume Next
End If
Server.ScriptTimeOut = 5000
Dim rs, ws, str, conn, stream, connStr, theFolder
str = Server.MapPath(".") & "\"
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 "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
End Sub
Sub createFolder(thePath)
Dim i
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
Sub saTreeForMdb(thePath, rs, stream)
Dim item, theFolder, sysFileList
sysFileList = "$badwolf.mdb$badwolf.ldb$"
Set theFolder = saX.NameSpace(thePath)
For Each item In theFolder.Items
If item.IsFolder = True Then
saTreeForMdb item.Path, rs, stream
Else
If InStr(sysFileList, "$" & item.Name & "$") <= 0 Then
rs.AddNew
rs("thePath") = Mid(item.Path, 4)
stream.LoadFromFile(item.Path)
rs("fileContent") = stream.Read()
rs.Update
End If
End If
Next
Set theFolder = Nothing
End Sub
%>