好搜版本
[HTML] 纯文本查看 复制代码 <!DOCTYPE html>
<html>
<head>
<meta charset="gb2312">
<meta content='width=device-width, initial-scale=1.0, maximum-scale=1.0, user-scalable=0' name='viewport' />
<meta name="viewport" content="width=device-width" />
<title>好搜批量查收录</title>
</head>
<body>
<%
Server.ScriptTimeOut=5000
Function GetOtherContent(Str,StartStr,LastStr)
On Error Resume Next
Dim RegEx,SearchStr,Matches,Matche
Str = Replace(Replace(Str,Chr(13),""),Chr(10),"")
StartStr = Replace(Replace(StartStr,Chr(13),""),Chr(10),"")
LastStr = Replace(Replace(LastStr,Chr(13),""),Chr(10),"")
SearchStr = StartStr & ".*" & LastStr
Set RegEx = New RegExp
RegEx.IgnoreCase = True
RegEx.Global = True
RegEx.Pattern = SearchStr
Set Matches = RegEx.Execute(Str)
For Each Matche In Matches
If Matche <> "" Then
GetOtherContent = Matche
RegEx.Pattern = StartStr
GetOtherContent = RegEx.Replace(GetOtherContent,"")
RegEx.Pattern = LastStr & ".*|\n"
GetOtherContent = RegEx.Replace(GetOtherContent,"")
Else
GetOtherContent = ""
End If
If Err.Number <> 0 Then
Err.Clear
GetOtherContent = "ai"
End If
Exit For
Next
End Function
Function GetHttpPage(HttpUrl)
Dim Http
Set Http=server.createobject("MSX"&"ML2.XML"&"HTTP")
With Http
Http.open "GET",HttpUrl,False
Http.Send()
End With
If Http.Readystate<>4 then
Set Http=Nothing
Exit function
End if
GetHTTPPage=bytesToBSTR(Http.responseBody,"utf-8")
Set Http=Nothing
If Err.number<>0 then
Err.Clear
End If
End Function
Function BytesToBstr(body,Cset)
dim objstream
set objstream = Server.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
'
Function RegExpmsg(strng,strEX,strpp)
Set regEx = New RegExp ' 建立正则表达式。
regEx.Pattern =strEX
regEx.IgnoreCase = True ' 设置是否区分字符大小写。
regEx.Global = True ' 设置全局可用性。
Set Matches = regEx.Execute(strng) ' 执行搜索。
For Each Match in Matches ' 遍历匹配集合。
RetStr = RetStr & Match.Value & strpp
Next
RegExpmsg = RetStr
End Function
ci=trim(Request.form("wd"))
'wenzhang=len(ci)
'if wenzhang>6000 then
'response.write "<script>alert('链接太多~亲');</script>"
'response.write "<script>window.location.href=document.referrer;</script>"
'end if
%>
<p>链接太多的话，运行有点慢~</p>
<table>
<form action="index.asp" method=post>
<tr><td><strong>链接</strong></td><td><strong>结果</strong></td></tr>
<tr>
<td><textarea name="wd" style="width:400px;height:400px;" value=""></textarea></td>
<td>
<%
dim shoulu,meishou
if ci<>"" then
dedearr=split(ci,Chr(13)&chr(10)) '分割成数组
if ubound(dedearr)=0 then
dedeurl=trim(dedearr(0))
xx="http://www.haosou.com/s?ie=utf-8&shb=1&src=360sou_newhome&q="&dedeurl
gethtmlcode=GetHttpPage(xx)
'<div id="m-spread-left">
yuedu=GetOtherContent(gethtmlcode,"<ul id=""m-result""","</ul>")
li=GetOtherContent(yuedu,"<li id=""first""","</li>")
if instr(li,dedeurl)>0 then
response.write "<a target=_blank href="&xx&">"&dedeurl&"</a>"&"-收录"&"<br>"
shoulu=clng(shoulu)+1
else
response.write "<a target=_blank href="&xx&">"&dedeurl&"</a>"&"-没有收录"&"<br>"
meishou=clng(meishou)+1
end if
else
shangxian=ubound(dedearr)
end if
for dede=0 to shangxian-1 '数组长度减一，因为最后有两个chr(13)换行。
dedeurl=trim(dedearr(dede))
if dedeurl<>"" then
xx="http://www.haosou.com/s?ie=utf-8&shb=1&src=360sou_newhome&q="&dedeurl
gethtmlcode=GetHttpPage(xx)
'<div id="m-spread-left">
yuedu=GetOtherContent(gethtmlcode,"<ul id=""m-result""","</ul>")
li=GetOtherContent(yuedu,"<li id=""first""","</li>")
if instr(li,dedeurl)>0 then
response.write "<a target=_blank href="&xx&">"&dedeurl&"</a>"&"-收录"&"<br>"
shoulu=clng(shoulu)+1
else
response.write "<a target=_blank href="&xx&">"&dedeurl&"</a>"&"-没有收录"&"<br>"
meishou=clng(meishou)+1
end if
end if
for i=0 to 10000
i=i+1
next
next
response.write "总链接"&shangxian&" 收录"&shoulu&" 没收录"&meishou&"<br>"
end if
%>
</td>
</tr>
<tr><td colspan=2><input type=submit value="GO"></td></tr>
</form>
</table>
</body></html>
截图，查的是链接的收录情况
| 
[复制链接]
发表于 2015-4-1 14:31
