<
%
' --------------------------------
' Baidu搜索小偷ASP完美版
' 作者:勇敢的风
' Blog:http://feng.cnblog.com.cn
' 使用或转载请保留这些信息
' Var VBScript 1.0
' 2006.3
' 由于Baidu经常修改界面,该版仅适用于2006年3月之前的最后一次该版
' 如搜索时出现错误或者提取的内容混乱则表示该版本寿命已用尽。
' --------------------------------
Function bytes2BSTR(vIn)
strReturn = ""
For i = 1 To LenB(vIn)
ThisCharCode = AscB(MidB(vIn,i, 1 ))
If ThisCharCode < & H80 Then
strReturn = strReturn & Chr (ThisCharCode)
Else
NextCharCode = AscB(MidB(vIn,i + 1 , 1 ))
strReturn = strReturn & Chr ( CLng (ThisCharCode) * & H100 + CInt (NextCharCode))
i = i + 1
End If
Next
bytes2BSTR = ubb(strReturn)
End Function
Function dq(key)
dim XmlHttp
set XmlHttp = CreateObject ( " Microsoft.XMLHTTP " )
XmlHttp.Open " GET " , " http://www.baidu.com/s?wd= " & key & " &pn= " & request( " pn " ), false
XmlHttp.setRequestHeader " Content-Type " , " text/XML "
XmlHttp.Send
dq = bytes2BSTR(XmlHttp.responseBody)
End Function
Function BR(Str)
Str = Replace (Str, " {br} " , " <br> " )
Str = Replace (Str,vbcrlf, " <br> " )
Str = Replace (Str, " <br> <br> " , " <br> " )
Str = Replace (Str, " <br><br> " , " <br> " )
Str = Replace (Str, " <br><br> " , " <br> " )
BR = Str
End Function
function ubb(str)
if instr (str, " 找到相关网页 " ) = 0 then
ubb = " 没有搜索到任何内容 "
exit function
end if
str = Replace (str,vbcrlf, " {br} " )
str = Replace (str, " <br> " , " {br} " )
str = Replace (str, " </td> " , " </td> " & vbcrlf)
str = Replace (str, " <td " ,vbcrlf & " <td " )
dim re,Match,Matches
set re = New RegExp
re.Global = True
re.IgnoreCase = True
re.Pattern = " .*<td class=f>(.*)</td> "
Set Matches = re.Execute(str)
For Each Match in Matches
ubb = ubb & BR(Match.value)
next
re.Pattern = " (- <a .[^<]*>百度快照</a>) "
ubb = re.replace(ubb, "" )
re.Pattern = " (<a class=""m"".[^<]*>.[^<]*</a>) "
ubb = re.replace(ubb, "" )
re.Pattern = " (<font color=#008000>.[^<]*</font>) "
ubb = re.replace(ubb, " <hr> " ) ' 每一条信息的间隔
ubb = Replace (ubb, " <td class=f> " , "" )
ubb = Replace (ubb, " </td> " , "" )
ubb = BR(UBB)
re.Pattern = " (找到相关网页.*秒) "
Set Matches = re.Execute(str)
set Match = Matches( 0 )
ubb = ubb & Match & " <br> "
str = Replace (str, " </div> " , " </div> " & vbcrlf)
re.Pattern = " <div class=""p"">(.*)</div> "
Set Matches = re.Execute(str)
set Match = Matches( 0 )
Dim TheLink
TheLink = Match
re.Pattern = " href=s?(.[^>]*) "
TheLink = re.replace(TheLink, " href=""$1"" " )
ubb = ubb & TheLink
end function
if len (request( " wd " )) > 0 then
response.write dq(request( " wd " ))
end if
% >
< form method = post action = " ? " >
< input type = " text " name = " wd " > < input type = " submit " >
</ form >
' --------------------------------
' Baidu搜索小偷ASP完美版
' 作者:勇敢的风
' Blog:http://feng.cnblog.com.cn
' 使用或转载请保留这些信息
' Var VBScript 1.0
' 2006.3
' 由于Baidu经常修改界面,该版仅适用于2006年3月之前的最后一次该版
' 如搜索时出现错误或者提取的内容混乱则表示该版本寿命已用尽。
' --------------------------------
Function bytes2BSTR(vIn)
strReturn = ""
For i = 1 To LenB(vIn)
ThisCharCode = AscB(MidB(vIn,i, 1 ))
If ThisCharCode < & H80 Then
strReturn = strReturn & Chr (ThisCharCode)
Else
NextCharCode = AscB(MidB(vIn,i + 1 , 1 ))
strReturn = strReturn & Chr ( CLng (ThisCharCode) * & H100 + CInt (NextCharCode))
i = i + 1
End If
Next
bytes2BSTR = ubb(strReturn)
End Function
Function dq(key)
dim XmlHttp
set XmlHttp = CreateObject ( " Microsoft.XMLHTTP " )
XmlHttp.Open " GET " , " http://www.baidu.com/s?wd= " & key & " &pn= " & request( " pn " ), false
XmlHttp.setRequestHeader " Content-Type " , " text/XML "
XmlHttp.Send
dq = bytes2BSTR(XmlHttp.responseBody)
End Function
Function BR(Str)
Str = Replace (Str, " {br} " , " <br> " )
Str = Replace (Str,vbcrlf, " <br> " )
Str = Replace (Str, " <br> <br> " , " <br> " )
Str = Replace (Str, " <br><br> " , " <br> " )
Str = Replace (Str, " <br><br> " , " <br> " )
BR = Str
End Function
function ubb(str)
if instr (str, " 找到相关网页 " ) = 0 then
ubb = " 没有搜索到任何内容 "
exit function
end if
str = Replace (str,vbcrlf, " {br} " )
str = Replace (str, " <br> " , " {br} " )
str = Replace (str, " </td> " , " </td> " & vbcrlf)
str = Replace (str, " <td " ,vbcrlf & " <td " )
dim re,Match,Matches
set re = New RegExp
re.Global = True
re.IgnoreCase = True
re.Pattern = " .*<td class=f>(.*)</td> "
Set Matches = re.Execute(str)
For Each Match in Matches
ubb = ubb & BR(Match.value)
next
re.Pattern = " (- <a .[^<]*>百度快照</a>) "
ubb = re.replace(ubb, "" )
re.Pattern = " (<a class=""m"".[^<]*>.[^<]*</a>) "
ubb = re.replace(ubb, "" )
re.Pattern = " (<font color=#008000>.[^<]*</font>) "
ubb = re.replace(ubb, " <hr> " ) ' 每一条信息的间隔
ubb = Replace (ubb, " <td class=f> " , "" )
ubb = Replace (ubb, " </td> " , "" )
ubb = BR(UBB)
re.Pattern = " (找到相关网页.*秒) "
Set Matches = re.Execute(str)
set Match = Matches( 0 )
ubb = ubb & Match & " <br> "
str = Replace (str, " </div> " , " </div> " & vbcrlf)
re.Pattern = " <div class=""p"">(.*)</div> "
Set Matches = re.Execute(str)
set Match = Matches( 0 )
Dim TheLink
TheLink = Match
re.Pattern = " href=s?(.[^>]*) "
TheLink = re.replace(TheLink, " href=""$1"" " )
ubb = ubb & TheLink
end function
if len (request( " wd " )) > 0 then
response.write dq(request( " wd " ))
end if
% >
< form method = post action = " ? " >
< input type = " text " name = " wd " > < input type = " submit " >
</ form >
<script type="text/javascript"> </script><script type="text/javascript" src="http://pagead2.googlesyndication.com/pagead/show_ads.js"> </script>