Set FSO = CreateObject("Scripting.FileSystemObject")
Set objXML = CreateObject("Microsoft.XmlHttp")
For i = 0 To 30 Step 10
   Url = "http://www.google.com.hk/search?q=*.blog.163.com/blog&hl=zh" _
   & "-CN&newwindow=1&safe=strict&gbv=2&prmd=ivns&start=" & i & "&sa=N"
   objXML.Open "Get",Url,False
   objXML.Send()
   Do Until objXML.ReadyState = 4 :Wscript.Sleep 200 :Loop
   Text = objXML.ResponseText
   Str = GetNameStr
Next
FSO.OpenTextFile("Result.txt",2,True).Write Str
CreateObject("Wscript.Shell").Run "NotePad Result.txt"

Function GetNameStr
   Set Re = New RegExp
   Re.Pattern = "http://(.[^/<>]*?\.blog\.163\.com/blog)"
   Re.IgnoreCase = True
   Re.Global = True
   For Each Match in Re.Execute(Text)
      a = Match.SubMatches(0)
      If InStr(LCase(Str),LCase(a)) = 0 Then Str = Str & a & vbCrLf
   Next
   GetNameStr = Str
End Function
复制代码

On Error Resume Next
Dim HomeUrl, Url
HomeUrl = "http://www.google.com.hk/search?q=*.blog.163.com/blog&hl=zh-CN&newwindow=1&safe=strict&gbv=2&prmd=ivns&ei=4wLwUNWTO4bhlAXx0IDgBw&start=@#$0&sa=N"
'自己修改10这个值来决定取多少页的数据
For i = 1 To 10
  If i = 1 Then 
    Url = Replace(HomeUrl, "@#$", "")
    Else
    Url = Replace(HomeUrl, "@#$", i - 1)
  End If
  GetText Url
Next
WScript.Echo "ok"

Function GetText(Url)
  Dim objXML
  Set objXML = CreateObject("MSXML2.XmlHttp")
  objXML.open "GET", Url, False
  objXML.send()
  If Err.Number = 0 Then
    Do Until objXML.readyState = 4 : WScript.Sleep 200 : Loop
    GetUrl objXML.responseText
    Else
    Err.Clear
  End If
  Set objXML = Nothing
End Function

Function GetUrl(Str)
  Dim objEXP, objItems, objItem
  Set objEXP = New RegExp
  objEXP.Global = True
  objEXP.IgnoreCase = True
  objEXP.Pattern = "q=http://([^/<>]+?\.blog\.163\.com)"
  Set objItems = objEXP.Execute(Str)
  For Each objItem In objItems
    WriteText objItem.Submatches(0)
  Next
  GetUrl = objStr 
  Set objEXP = Nothing
End Function

Function WriteText(NewUrl)
  Dim FSO, Ty
  Set FSO = CreateObject("Scripting.Filesystemobject")
  NewUrl = NewUrl & "/blog"
  Ty = 2
  If FSO.FileExists("UrlList.txt") Then Ty = 8
  FSO.OpenTextFile("UrlList.txt", Ty, True).WriteLine NewUrl
  Set FSO = Nothing  
End Function
复制代码