VBS搜索引擎收录数查询

on error resume next 
weburl = InputBox("查询的网址", "DOS资源站", "http://www.cmdos.net")  
weburl = Replace(weburl, "http://", "")  
NO_baidu = getContents("找到相关网页*(.+?)篇", getHTTPPage("http://www.baidu.com/s?wd=site:" & weburl, "GB2312"), TRUE)(0)  
NO_google = getContents("约有 <b>(.+?)</b> 项符合", getHTTPPage("http://www.google.cn/search?q=site:" & weburl, "utf-8"), TRUE)(0)  
NO_yahoo = getContents("共 <strong>(.+?)</strong> 条", getHTTPPage("http://sitemap.cn.yahoo.com/search?p=" & weburl, "utf-8"), TRUE)(0) 

NO_live = getContents("（共 (.+?) 条）", getHTTPPage("http://cnweb.search.live.com/results.aspx?q=site:" & weburl, "utf-8"), TRUE)(0)  
NO_sogou = getContents("找到 (.+?) 个网页", getHTTPPage("http://www.sogou.com/web?query=site:" & weburl, "GB2312"), TRUE)(0) 

Str = Str & vbCrLf & "baidu: " & NO_baidu  
Str = Str & vbCrLf & "google:" & NO_google  
Str = Str & vbCrLf & "yahoo: " & NO_yahoo  
Str = Str & vbCrLf & "live:  " & NO_live  
Str = Str & vbCrLf & "sogou: " & NO_sogou  
MsgBox Str  
 
 
 
'<---------------------------------------XMLHTTP------------------------------------->  
 
Function getHTTPPage(Path, CodePage)  
    t = GetBody(Path)  
    getHTTPPage = BytesToBstr(t, CodePage)  
End Function 
 
Function GetBody(url)  
    On Error Resume Next 
    Set xmlhttp = CreateObject("Microsoft.XMLHTTP")  
    With xmlhttp  
        .Open "Get", url, False 
        .Send  
        .waitForResponse 1000  
        GetBody = .ResponseBody  
    End With 
    Set xmlhttp = Nothing 
End Function 
 
Function BytesToBstr(Body, Cset)  
    On Error Resume Next 
    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 
 
 
'<---------------------------------------/ XMLHTTP------------------------------------->  
 
'得到匹配的内容，并以数据形式显示  
'表达式，字符串，是否返回引用值  
'msgbox getContents("a(.+?)b", "a23234b ab a67896896b sadfasdfb" ,True)(0)  
 
Function getContents(patrn, strng , yinyong)  
    Dim re, Matches, i, oMatch  
    Set re = New RegExp 
    re.Pattern = patrn  
    re.IgnoreCase = True 
    re.Global = True 
    Set Matches = re.Execute(strng)  
    If yinyong Then 
        For i = 0 To Matches.Count -1  
            If Matches(i).Value<>"" Then RetStr = RetStr & Matches(i).SubMatches(0) & "DOS资源站" 
        Next 
    Else 
        For Each oMatch in Matches  
            If oMatch.Value<>"" Then RetStr = RetStr & oMatch.Value & "DOS资源站" 
        Next 
    End If 
    getContents = Split(RetStr, "DOS资源站")  
End Function