Professional website packaging/unpacking asp tool (hard‑packed E version )!

Last Update:2018-12-05 Source: Internet

Author: User

Tags unpack

Developer on Alibaba Coud: Build your first app with APIs, SDKs, and tutorials on the Alibaba Cloud. Read more ＞

Professional website packaging/unpacking asp tool (hard‑packed E version )!

This asp program is suitable for uploading personal websites that are too large and compressed into one file!

It is also suitable for compressing the website without an ftp password before downloading it!

Reposted: Bad Wolf safety net www.winshell.cn

File Size: (8 K)

For the code, see (copy the text and change the extension to 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 "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/>"
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 "Echo "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-width: 1px; color: #000000 ;}" & vbNewLine
Echo "table {font-size: 9pt;}" & vbNewLine
Echo "form {margin: 0;}" & vbNewLine
Echo "# fsoDriveList span {width: 100px;}" & vbNewLine
Echo "# FileList span {width: 90; height: 70; cursor: hand; text-align: center; word-break: break-all; border: 1px solid buttonface ;} "& vbNewLine
Echo ". anotherSpan {color: # ffffff; width: 90; height: 70; text-align: center; background-color: # 0A246A; border: 1px solid # 0A246A;} "& vbNewLine
Echo ". font {font-size: 35px; line-height: 40px;}" & vbNewLine
Echo "# filecyclertools {background-color: buttonFace;}" & vbNewLine
Echo ". input, input {border-width: 1px;}" & vbNewLine
Echo "</style>" & vbNewLine
Echo "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 "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 "Echo "</form>" & vbNewLine
Echo "</body>"
Echo "

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"), faster Rev (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
%>

This article is an English version of an article which is originally in the Chinese language on aliyun.com and is provided for information purposes only. This website makes no representation or warranty of any kind, either expressed or implied, as to the accuracy, completeness ownership or reliability of the article or any translations thereof. If you have any concerns or complaints relating to the article, please send an email, providing a detailed description of the concern or complaint, to info-contact@alibabacloud.com. A staff member will contact you within 5 working days. Once verified, infringing content will be removed immediately.

A Free Trial That Lets You Build Big!

Start building with 50+ products and up to 12 months usage for Elastic Compute Service

Get Started for Free

Sales Support

1 on 1 presale consultation

Chat Contact Sales
After-Sales Support

24/7 Technical Support 6 Free Tickets per Quarter Faster Response

Open a Ticket
Alibaba Cloud offers highly flexible support services tailored to meet your exact needs.

Learn More