'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