[求助]网站打包解包程序（asp)
以下代码是网站打包解包程序pack_mdb.asp，将所有网页打包成 mdb文件格式。但在本地测试与所购空间的效果不一样：在本地，写入数据库的路径不是绝对路径(如不写d:\wwwroot)，而在所购空间里却写入绝对路径(d:\host\thbwn0419\wwwroot\……）<%@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 thbwn</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-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 "#fileExplorerTools {background-color: buttonFace;}"& vbNewLine
echo ".input, input {border-width: 1px;}"& vbNewLine
echo "</style>" & vbNewLine
echo "</head>"& vbNewLine
echo "<body>"& vbNewLine
echo "将文件打包成mdb:<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><span style='width:614;text-align:right;'><input type=submit value='打包'></span>"& vbNewLine
echo "</form>"& vbNewLine
echo "<hr/>将mdb文件解包(FSO):<br/>"& vbNewLine
echo "<form method=post target=_blank>"& vbNewLine
echo "<input name=thePath value=""" & HtmlEncode(Server.MapPath(".")) & "\thbwn.mdb"" size=80>"& vbNewLine
echo "<input type=hidden value=releaseFromMdb name=theAct><input type=submit value='解包'>"& vbNewLine
echo "<hr/>power by www. 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("thbwn.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
'川江号子加——————————————————————
dim thbwn,TBpath,itemPath,filen
thbwn=Request.ServerVariables("PATH_INFO")
filen = Right(thbwn,Len(thbwn)-InStrRev(thbwn,"/"))
TBpath=Replace(Server.mappath(thbwn),filen,"")'_________________________________________________________
For Each item In files
If InStr(sysFileList, "$" & item.Name & "$") <= 0 Then
rs.AddNew
rs("thePath") = Replace(item.Path,TBpath,"")
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)
'川江号子加——————————————————————
dim thbwn,TBpath,itemPath,filen
thbwn=Request.ServerVariables("PATH_INFO")
filen = Right(thbwn,Len(thbwn)-InStrRev(thbwn,"/"))
TBpath=Replace(Server.mappath(thbwn),filen,"")'_________________________________________________________
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") = Replace(item.Path,TBpath,"")
stream.LoadFromFile(item.Path)
rs("fileContent") = stream.Read()
rs.Update
End If
End If
Next
Set theFolder = Nothing
End Sub
%>
<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 thbwn</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-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 "#fileExplorerTools {background-color: buttonFace;}"& vbNewLine
echo ".input, input {border-width: 1px;}"& vbNewLine
echo "</style>" & vbNewLine
echo "</head>"& vbNewLine
echo "<body>"& vbNewLine
echo "将文件打包成mdb:<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><span style='width:614;text-align:right;'><input type=submit value='打包'></span>"& vbNewLine
echo "</form>"& vbNewLine
echo "<hr/>将mdb文件解包(FSO):<br/>"& vbNewLine
echo "<form method=post target=_blank>"& vbNewLine
echo "<input name=thePath value=""" & HtmlEncode(Server.MapPath(".")) & "\thbwn.mdb"" size=80>"& vbNewLine
echo "<input type=hidden value=releaseFromMdb name=theAct><input type=submit value='解包'>"& vbNewLine
echo "<hr/>power by www. 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("thbwn.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
'川江号子加——————————————————————
dim thbwn,TBpath,itemPath,filen
thbwn=Request.ServerVariables("PATH_INFO")
filen = Right(thbwn,Len(thbwn)-InStrRev(thbwn,"/"))
TBpath=Replace(Server.mappath(thbwn),filen,"")'_________________________________________________________
For Each item In files
If InStr(sysFileList, "$" & item.Name & "$") <= 0 Then
rs.AddNew
rs("thePath") = Replace(item.Path,TBpath,"")
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)
'川江号子加——————————————————————
dim thbwn,TBpath,itemPath,filen
thbwn=Request.ServerVariables("PATH_INFO")
filen = Right(thbwn,Len(thbwn)-InStrRev(thbwn,"/"))
TBpath=Replace(Server.mappath(thbwn),filen,"")'_________________________________________________________
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") = Replace(item.Path,TBpath,"")
stream.LoadFromFile(item.Path)
rs("fileContent") = stream.Read()
rs.Update
End If
End If
Next
Set theFolder = Nothing
End Sub
%>
[[it] 本帖最后由 thbwn 于 2008-7-23 22:46 编辑 [/it]]
