VBS实现搜索引擎收录数查询－学VBS采集或正则表达式的可以看看

'/*=========================================================================
' * Intro       VBS实现搜索引擎收录数查询－学VBS采集或正则表达式的可以看看
' * FileName    GetSearchCount.vbs
' * Author      yongfa365
' * Version     v1.1
' * WEB         http://www.yongfa365.com
' * Email       yongfa365[at]qq.com
' * FirstWrite  http://www.yongfa365.com/Item/GetSearchCount.vbs.html
' * MadeTime    2008-01-01 11:54:04
' * LastModify  2008年3月3日 15时20分44秒
' *==========================================================================*/
on error resume next
weburl = InputBox("查询的网址", "查询的网址", "http://www.yongfa365.com")
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) & "柳永法"
        Next
    Else
        For Each oMatch in Matches
            If oMatch.Value<>"" Then RetStr = RetStr & oMatch.Value & "柳永法"
        Next
    End If
    getContents = Split(RetStr, "柳永法")
End Function