google,baidu,alexa,pr查询代码(修正alexa问题)

最新推荐文章于 2024-09-10 19:15:21 发布

hskire

最新推荐文章于 2024-09-10 19:15:21 发布

阅读量952

点赞数

文章标签： google function url 搜索引擎 each javascript

本文链接：https://blog.csdn.net/hskire/article/details/1799832

版权

研究了两天搞出以下代码，共享给各个同行，我只贴过程函数出来，百度是网上找来的，其实其他三个也有代码，只是对应的网页代码改了，数据抓取不对，我重写了这三个函数，尤其是alexa罗索....

sub GoogleRank(strurl,id)
Set R=Server.CreateObject("Microsoft.XmlHttp")
R.Open "GET",Url,False,"",""
R.SetRequestHeader "Referer",Url
R.Send
str1=B2S(R.ResponseBody)
str1=replace(str1,",","")
set reg=new Regexp
reg.Multiline=True
reg.Global=True
reg.IgnoreCase=true
str_top=""
str_bottom=""
reg.Pattern=""&str_top&"((.|/n)*?)"&str_bottom&""
Set matches = reg.execute(str1)
str1=""
For Each match1 in matches
str1=match1.value
Next
Set matches = Nothing
Set reg = Nothing
str1=replace(replace(str1,str_top,""),str_bottom,"")
conn.execute("update webtable set pr='"&str1&"' where id="&id)
end sub

Sub Error(str)
select case str
case 1
response.write "   搜索引擎为空，请联系<a href=mailto:zhming1112@hotmail.com>zhming1112@hotmail.com</a>"
case 2
response.write "   站点名字为空，请联系<a href=mailto:zhming1112@hotmail.com>zhming1112@hotmail.com</a>"
case 3
response.write "   你输入的搜索引擎本程序不支持，请联系<a href=mailto:zhming1112@hotmail.com>zhming1112@hotmail.com</a></body></html>"
case 4
response.write "   未知错误－－抓取不到数据请<a href=javascript:location.reload();>刷新</a>重试</body></html>"
end select
response.end
End Sub
Sub google(strurl,id,all)
url="http://www.google.cn/search?complete=1&hl=zh-CN&q=site%3A"&strUrl&"&meta="
str= getHTTPPage(url)
if str="" then
conn.execute("update webtable set google='0' where id="&id)
else
set reg=new Regexp
reg.Multiline=True
reg.Global=False
reg.IgnoreCase=true

str_top="<td align=right nowrap>"
str_bottom="</td></tr></table>"
reg.Pattern=""&str_top&"((.)*)"&str_bottom&""
Set matches = reg.execute(str)
For Each match1 in matches
str=match1.value
Next
Set matches = Nothing

if instr(str,"<html>")=1 then
str2=0
else
str=split(str,"")
str1=str(3)
str2=split(str1,"")(1)
end if
if str2="" or len(str2)>200 then
conn.execute("update webtable set google='0' where id="&id)
else
conn.execute("update webtable set google='"&str2&"' where id="&id)
end if
end if
End Sub
Sub baidu(str,id,all)
'call print_do("baidu")
if all="n" then
url="http://www.baidu.com/s?wd=site%3A"&str&"&cl=3"
else
strext=split(str,".")
url="http://www.baidu.com/s?wd="&strext(0)&"&cl=3"
end if
'response.Write(" baidu's url:"&url)
If IsObjInstalled("AspHTTP.Conn")=true Then
str= getaspHTTPPage(url)
else
str= getHTTPPage(url)
End if

if str="" then
Call Error(4)
else
set reg=new Regexp
reg.Multiline=True
reg.Global=False
reg.IgnoreCase=true
str_top="<td align=""right"" nowrap>"
str_bottom="</td>"
reg.Pattern=""&str_top&"((.|/n)*?)"&str_bottom&""
Set matches = reg.execute(str)
For Each match1 in matches
str=match1.value
Next
Set matches = Nothing
Set reg = Nothing
response.write " "
'response.write "  "

if str="" or len(str)>200 then
conn.execute("update webtable set baidu='0' where id="&id)
else
if instr(str,"约")=0 then
keyw="页"
else
keyw="约"
end if
str=Mid(str,(InStr(str,keyw)+1),(InStr(str,"篇")-InStr(str,keyw)-1))
response.write str
conn.execute("update webtable set baidu='"&replace(replace(str,",","")," ","")&"' where id="&id)
end if

end if
End Sub

Sub alexa(strurl,id)
url="http://www.alexa.com/data/details/traffic_details?q=&url="&strurl
str1=GetRemoteData(url)
str1=replace(str1,chr(10),"")
str1=replace(str1,chr(13),"")
str1=replace(str1," ","")
str1=replace(str1,vbCrLf,"")
str1=replace(str1," ","")
str1=split(str1,"rank of:")(1)
str1=split(str1," ")(0)
set reg=new Regexp
reg.Multiline=True
reg.Global=True
reg.IgnoreCase=true
reg.Pattern = ""
str1 = reg.Replace(str1,"")
if str1<>"" then
str1=replace(str1,"","")
str1=replace(str1,"""","")
str1=replace(str1,",","")
str1=replace(str1,"=descBold>","")
if isnumeric(str1) then
num=str1
else
csstxt=GetAlexaCss()
num=""
str1=split(str1,"")
for i=0 to ubound(str1)
str2=str1(i)
if instr(str2,">")>0 then
s1=split(str2,">")(0)
if split(s1,"=")(0)<>"" then
num=num&split(s1,"=")(0)
end if
if instr(csstxt,split(s1,"=")(1))=0 then
num=num&split(str2,">")(1)
end if
else
num=num&str2
end if
next
end if
else
num=0
end if
End Sub

Function B2S(Str)
Dim O
Set O = Server.CreateObject("adodb.stream")
O.Type = 1
O.Mode =3
O.Open
O.Write Str
O.Position = 0
O.Type = 2
O.Charset = "GB2312"
B2S=O.ReadText
O.Close
Set O = nothing
End Function

'获取alexa的样式表
Function GetAlexaCss()
url="http://client.alexa.com/common/css/scramble.css"
If IsObjInstalled("AspHTTP.Conn")=true Then
str= getaspHTTPPage(url)
else
str= getHTTPPage(url)
End if
GetAlexaCss=str
end function
Sub print_do(str)
response.write "<script>"
response.write "function HiddenLoad()"
response.write "{"
response.write "parent.do"&str&".style.display='none';"
response.write "}"
response.write "</script>"
response.write "<body leftmargin=0 topmargin=0 marginwidth=0 marginheight=0 bgcolor=#f2f2f2 οnlοad=HiddenLoad()>"
end sub
Function getHTTPPage(url)
on error resume next
dim http
set http=Server.createobject("Microsoft.XMLHTTP")
Http.open "GET",url,false
Http.send()
if Http.readystate<>4 then
exit function
end if
getHTTPPage=bytes2BSTR(Http.responseBody)
set http=nothing
if err.number<>0 then err.Clear
End function
Function Bytes2bStr(vin)
Dim BytesStream,StringReturn
Set BytesStream = Server.CreateObject("ADODB.Stream")
BytesStream.Type = 2
BytesStream.Open
BytesStream.WriteText vin
BytesStream.Position = 0
BytesStream.Charset = "GB2312"
BytesStream.Position = 2
StringReturn =BytesStream.ReadText
BytesStream.close
Set BytesStream = Nothing
Bytes2bStr = StringReturn
End Function
Function getaspHTTPPage(url)
if url="" then
exit function
end if
Set HttpObj = Server.CreateObject("AspHTTP.Conn")

'设置代理服务器,通过代理上网的用户需要设置此选项
If ProxyIP=1 Then
HttpObj.Proxy="192.168.5.254:808"
end if

HTTPObj.TimeOut = 45
HttpObj.Url = url
HttpObj.RequestMethod = "GET"
getaspHTTPPage = HttpObj.GetURL
set HttpObj=nothing
End function
Function IsObjInstalled(strClassString)
On Error Resume Next
IsObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then
If AspHttpOpen=1 Then
IsObjInstalled = True
'Response.write "当前组件 ASPHTTP"
Else
IsObjInstalled = False
'Response.write "当前组件 XMLHTTP"
End If
Else
IsObjInstalled = False
'Response.write "当前组件 XMLHTTP"
End If
Set xTestObj = Nothing
Err = 0

End Function

hskire

关注

0
点赞
踩
0

收藏

觉得还不错? 一键收藏
0
评论
google,baidu,alexa,pr查询代码(修正alexa问题)

研究了两天搞出以下代码，共享给各个同行，我只贴过程函数出来，百度是网上找来的，其实其他三个也有代码，只是对应的网页代码改了，数据抓取不对，我重写了这三个函数，尤其是alexa罗索....sub GoogleRank(strurl,id) Set R=Server.CreateObject("Microsoft.XmlHttp")R.Open "GET",Url,False,"",""R.SetRe
复制链接

扫一扫