本帖最后由 batman 于 2013-1-13 14:55 编辑
这样大规模地搜索，楼主想做什么？ 不是想要批量发广告吧？- 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
| 
发表于 2013-1-11 13:02
| 
D=zh-CN:NW=1:TM=1358068153:LM=1358068153:S=Qj66rIpCbwYOKJtL