vbs搜索代理

 '1、输入url目标网页地址，返回值getHTTPPage是目标网页的html代码
function getHTTPPage(url)
dim Http
set Http=CreateObject("MSXML2.XMLHTTP")
Http.open "GET",url,false
Http.send()
if Http.readystate<>4 then
exit function
end if
getHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
set http=nothing
if err.number<>0 then err.Clear
end function

'2、转换乱玛，直接用xmlhttp调用有中文字符的网页得到的将是乱玛，可以通过adodb.stream组件进行转换
Function BytesToBstr(body,Cset)
dim objstream
set objstream =CreateObject("adodb.stream")
objstream.Type = 1
objstream.Mode = 3
objstream.Open
objstream.Write body
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Close
set objstream = nothing
End Function

'下面试着调用http://www.proxycn.com/html_proxy/30fastproxy-1.html的html内容
Dim Url,Html,Temp
Url="http://www.proxycn.com/html_proxy/30fastproxy-1.html"
Html = getHTTPPage(Url)
Call getinfo(html)

Sub Getinfo(S)
Dim pl(),m,St
St="</TD><TD class=" & """list""" & ">"
Do
   m = m + 1
   n = P + Len(St)
   P = InStr(n,S,St)
   ReDim Preserve pl(m-1)
   pl(m-1) = P
loop While P <> 0

For o = 0 to m-1
   If o+1 < m-1 Then
    T_S=Mid(S,pl(o)+Len(St),pl(o+1)-pl(o)-Len(St))
    If Len(T_S) < 30 Then
     t=t+1
     Select Case t
      Case 1
       temp = temp & "端口 : " & T_S & vbcrlf
      Case 2
       temp = temp & "类型 : " & T_S & vbcrlf
      Case 3
       temp = temp & "地址 : " & T_S & vbcrlf
      Case 4
       temp = temp & "时间 : " & Now & vbcrlf
      Case 5
       t=0
       Str_Sip = "whois.php?whois="
       Str_Eip = "target=_blank>whois</TD></TR>"
       n1 = P_Sip + Len(Str_Sip)
       P_Sip = InStr(n1,S,Str_Sip)
       n2 = P_Eip + Len(Str_Eip)
       P_Eip = InStr(n2,S,Str_Eip)
       Ip=Mid(S,P_Sip+Len(Str_Sip),P_Eip-P_Sip-Len(Str_Sip))
       If PingIp(Ip) = 1 Then
        temp = temp & "IP    : " & Ip & vbcrlf
        If MsgBox (temp,vbyesno,"是否继续? " )=vbno Then
         WScript.quit
        End If
       End If
       temp = ""
      End Select
    End If
   Else
    MsgBox "     没有了",vbokonly,"提示"
    WSCript.quit
   End If
Next
End Sub

Function PingIp(host)
On Error Resume Next
strComputer = "."
strTarget = host
Set objWMIService = GetObject("winmgmts:" _
   & "{impersonationLevel=impersonate}!//" & strComputer & "/root/cimv2")
Set colPings = objWMIService.ExecQuery _
   ("Select * From Win32_PingStatus where Address = '" & strTarget & "'")
If Err = 0 Then
    Err.Clear
    For Each objPing in colPings
      If Err = 0 Then
        Err.Clear
        If objPing.StatusCode = 0 Then
         PingIp = 1
         temp = temp & "速度 : " & objPing.ResponseTime & " 毫秒" & vbcrlf
          'MsgBox   strTarget & " responded to ping." & vbcrlf &_
          '"Responding Address: " & objPing.ProtocolAddress & vbcrlf &_
          '"Responding Name: " & objPing.ProtocolAddressResolved & vbcrlf &_
          '"Bytes Sent: " & objPing.BufferSize & vbcrlf &_
          '"Time: " & objPing.ResponseTime & " ms" & vbcrlf &_
          '"TTL: " & objPing.ResponseTimeToLive & " seconds"
        Else
         PingIp = 0
          'MsgBox strTarget & " did not respond to ping." &_
          '"Status Code: " & objPing.StatusCode
        End If
      Else
        Err.Clear
        PingIP = 0
        'MsgBox "Unable to call Win32_PingStatus on " & strComputer & "."     
      End If
    Next
Else
    Err.Clear
    PingIp = 0
    'MsgBox "Unable to call Win32_PingStatus on " & strComputer & "."
End If
End Function