Asp网页搜索引擎，绝对原创，本文章提供源代码
2008-12-31 14:26
501 查看
实例地址：http://www.xin800.com/websearch/old/
实现效果：
本程序未加函数说明，有朋友想一起研究的话可以加我的QQ: 68807917
程序代码：
<%stimer=timer()%><html><head>
<meta http-equiv="content-type" content="text/html; charset=gb2312" />
<title>网页搜索系统</title>
<style type="text/css"><!--
td {font-size: 12px;text-decoration: none;}
.content {font-size: 12px;color: #333333;text-decoration: none;line-height: 18px;}
.title {font-size: 14px;font-weight: normal;color: #996600;text-decoration: underline;}
.info {font-size: 12px;color: #996600;text-decoration: none;}
body {margin-left: 30px;margin-top: 10px;font-size: 12px;}
--></style></head>
<body>
<form name="form1" method="post" action="">
<table width="683" border="0" cellspacing="0" cellpadding="0">
<tr>
<td width="137" height="25" align="right"> </td>
<td width="546"> 网页搜索</td></tr>
<tr>
<td height="25" align="right">关键字:</td>
<td>
<input name="keyword" type="text" id="keyword" value="<%=request.form("keyword")%>" size="30">
<input type="submit" name="submit" value="开始搜索">
<input name="Action" type="hidden" id="Action" value="true"></td></tr>
<tr>
<td height="25" align="right">收录站点:</td>
<td> <textarea name="Domains" id="Domains" cols="45" rows="5"><%
If Trim(Request("Domains"))="" Then
Response.Write("http://www.xin800.com"&vbcrlf)
Response.Write("http://www.baidu.com"&vbcrlf)
Response.Write("http://www.sina.com.cn"&vbcrlf)
Response.Write("http://www.sohu.com"&vbcrlf)
Response.Write("http://www.163.com")
Else
Response.Write(Trim(Request("Domains")))
End if
%></textarea></td>
</tr>
</table>
</form>
<%
'*****************************************
'本程序源创 极限风暴
'未经本人许可禁止转载
'*****************************************
function geturl(url, pagecode)
set http=server.createobject("microsoft.xmlhttp")
on error resume next
http.open "get",url,false
http.send()
if err then
err.clear
geturl="没有找到网页!"
else
gethttppage=bytestobstr(http.responsebody,pagecode)
end if
set http=nothing
geturl=gethttppage
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 removehtml(strhtml)
strhtml = replace(strhtml,vbcrlf,"")
strhtml = replace(strhtml,chr(13)&chr(10),"")
strhtml = replace(strhtml,chr(13),"")
strhtml = replace(strhtml,chr(10),"")
strhtml = replace(strhtml," ","")
strhtml = replace(strhtml," ","")
dim objregexp, match, matches
set objregexp = new regexp
objregexp.ignorecase = true
objregexp.global = true
objregexp.pattern = "<style(.+?)</style>"
set matches = objregexp.execute(strhtml)
for each match in matches
strhtml=replace(strhtml,match.value,"")
next
objregexp.pattern = "<script(.+?)</script>"
set matches = objregexp.execute(strhtml)
for each match in matches
strhtml=replace(strhtml,match.value,"")
next
objregexp.pattern = "<title(.+?)</title>"
set matches = objregexp.execute(strhtml)
for each match in matches
strhtml=replace(strhtml,match.value,"")
next
objregexp.pattern = "<!--(.+?)-->"
set matches = objregexp.execute(strhtml)
for each match in matches
strhtml=replace(strhtml,match.value,"")
next
objregexp.pattern = "<.+?>"
set matches = objregexp.execute(strhtml)
for each match in matches
strhtml=replace(strhtml,match.value,"")
next
removehtml=strhtml
set objregexp = nothing
end function
function strcut(strcontent,startstr,endstr,cuttype)
dim strhtml,s1,s2
strhtml = strcontent
on error resume next
select case cuttype
case 1
s1 = instr(strhtml,startstr)
s2 = instr(s1,strhtml,endstr)+len(endstr)
case 2
s1 = instr(strhtml,startstr)+len(startstr)
s2 = instr(s1,strhtml,endstr)
end select
if err then
strcute = "<p align='center'>没有找到需要的内容。</p>"
err.clear
exit function
else
strcut = mid(strhtml,s1,s2-s1)
end if
end function
function webpagecode(domain)
content=lcase(geturl(domain, "gb2312"))
dim metaexp, matchs, matchess, strhtml
set metaexp = new regexp
metaexp.ignorecase = true
metaexp.global = true
metaexp.pattern = "<meta(.+?)/>"
set matchess = metaexp.execute(content)
for each matchs in matchess
strhtml=strhtml&matchs.value
next
metaexp.pattern = "charset=(.+?)"""
set matchess = metaexp.execute(strhtml)
for each matchs in matchess
strhtml=replace(replace(matchs.value,"charset=",""),"""","")
next
if strhtml="" then
strhtml="gb2312"
end if
webpagecode=strhtml
end function
function webpagesearch(domain, keyword)
dim content, searchtitle, contentlength, keywordbit , responsecontentcount
dim searchinfo, searchurl, searchcontent
if webpagecode(domain)="gb2312" then
content=geturl(domain, "gb2312")
else
content=geturl(domain, webpagecode(domain))
end if
searchtitle=strcut(lcase(content),"<title>","</title>",2)
content=removehtml(content)
contentlength=len(content)
keywordbit=instr(1,lcase(content),keyword,1)
responsecontentcount=70
if contentlength>responsecontentcount*2 then
if clng(keywordbit)-responsecontentcount<0 and clng(keywordbit)+responsecontentcount<=contentlength then
content=left(content,clng(keywordbit)+responsecontentcount)
end if
if clng(keywordbit)>50 and clng(keywordbit)+responsecontentcount<=contentlength then
on error resume next
content=mid(left(content,clng(keywordbit)+responsecontentcount),clng(keywordbit)-responsecontentcount-1)
if err then
err.clear
content=left(content,clng(keywordbit)+responsecontentcount)
end if
end if
end if
content=replace(content,keyword,"<font color=red><b>"&keyword&"</b></font>")
searchtitle=replace(searchtitle,keyword,"<font color=red><b>"&keyword&"</b></font>")
searchinfo="网页内容长度:"&contentlength&" 关健字位置:"&keywordbit
searchcontent=content
searchurl=domain
webpagesearch="<table width=""450"" border=""0"" cellspacing=""0"" cellpadding=""0"">" & _
"<tr><td height=""26"">"&searchinfo&"</td></tr>" & _
"<tr><td height=""26"" class=""title"">" & _
"<a href="&searchurl&" target=""_blank"" class=""title"">" & _
""&searchtitle&"</a></td></tr>" & _
"<tr><td height=""55"" class=""content"" >"& _
" "&searchcontent&"</td></tr>" & _
"<tr><td height=""26"" class=""info"" >" & _
"<a href="&searchurl&" target=""_blank"">"&searchurl&"</a>" & _
" "&date()&"</td>" & _
"</tr></table>"
end function
action=trim(request.form("action"))
if action="true" then
Domains=Trim(Request("Domains"))
Domains=Replace(Domains,vbcrlf,"|")
Domain=split(Domains, "|")
keyword=trim(request.form("keyword"))
For i=0 To Ubound(Domain)
Response.Write(Webpagesearch(Domain(i), keyword)&"<br>")
Next
etimer=timer
if etimer-stimer>1 then
response.write("搜索共用: "&etimer-stimer&" 秒")
else
response.write("搜索共用: 0"&etimer-stimer&" 秒")
end if
End if
'*****************************************
'本程序源创 极限风暴
'*****************************************
%></body></html>
实现效果：
本程序未加函数说明，有朋友想一起研究的话可以加我的QQ: 68807917
程序代码：
<%stimer=timer()%><html><head>
<meta http-equiv="content-type" content="text/html; charset=gb2312" />
<title>网页搜索系统</title>
<style type="text/css"><!--
td {font-size: 12px;text-decoration: none;}
.content {font-size: 12px;color: #333333;text-decoration: none;line-height: 18px;}
.title {font-size: 14px;font-weight: normal;color: #996600;text-decoration: underline;}
.info {font-size: 12px;color: #996600;text-decoration: none;}
body {margin-left: 30px;margin-top: 10px;font-size: 12px;}
--></style></head>
<body>
<form name="form1" method="post" action="">
<table width="683" border="0" cellspacing="0" cellpadding="0">
<tr>
<td width="137" height="25" align="right"> </td>
<td width="546"> 网页搜索</td></tr>
<tr>
<td height="25" align="right">关键字:</td>
<td>
<input name="keyword" type="text" id="keyword" value="<%=request.form("keyword")%>" size="30">
<input type="submit" name="submit" value="开始搜索">
<input name="Action" type="hidden" id="Action" value="true"></td></tr>
<tr>
<td height="25" align="right">收录站点:</td>
<td> <textarea name="Domains" id="Domains" cols="45" rows="5"><%
If Trim(Request("Domains"))="" Then
Response.Write("http://www.xin800.com"&vbcrlf)
Response.Write("http://www.baidu.com"&vbcrlf)
Response.Write("http://www.sina.com.cn"&vbcrlf)
Response.Write("http://www.sohu.com"&vbcrlf)
Response.Write("http://www.163.com")
Else
Response.Write(Trim(Request("Domains")))
End if
%></textarea></td>
</tr>
</table>
</form>
<%
'*****************************************
'本程序源创 极限风暴
'未经本人许可禁止转载
'*****************************************
function geturl(url, pagecode)
set http=server.createobject("microsoft.xmlhttp")
on error resume next
http.open "get",url,false
http.send()
if err then
err.clear
geturl="没有找到网页!"
else
gethttppage=bytestobstr(http.responsebody,pagecode)
end if
set http=nothing
geturl=gethttppage
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 removehtml(strhtml)
strhtml = replace(strhtml,vbcrlf,"")
strhtml = replace(strhtml,chr(13)&chr(10),"")
strhtml = replace(strhtml,chr(13),"")
strhtml = replace(strhtml,chr(10),"")
strhtml = replace(strhtml," ","")
strhtml = replace(strhtml," ","")
dim objregexp, match, matches
set objregexp = new regexp
objregexp.ignorecase = true
objregexp.global = true
objregexp.pattern = "<style(.+?)</style>"
set matches = objregexp.execute(strhtml)
for each match in matches
strhtml=replace(strhtml,match.value,"")
next
objregexp.pattern = "<script(.+?)</script>"
set matches = objregexp.execute(strhtml)
for each match in matches
strhtml=replace(strhtml,match.value,"")
next
objregexp.pattern = "<title(.+?)</title>"
set matches = objregexp.execute(strhtml)
for each match in matches
strhtml=replace(strhtml,match.value,"")
next
objregexp.pattern = "<!--(.+?)-->"
set matches = objregexp.execute(strhtml)
for each match in matches
strhtml=replace(strhtml,match.value,"")
next
objregexp.pattern = "<.+?>"
set matches = objregexp.execute(strhtml)
for each match in matches
strhtml=replace(strhtml,match.value,"")
next
removehtml=strhtml
set objregexp = nothing
end function
function strcut(strcontent,startstr,endstr,cuttype)
dim strhtml,s1,s2
strhtml = strcontent
on error resume next
select case cuttype
case 1
s1 = instr(strhtml,startstr)
s2 = instr(s1,strhtml,endstr)+len(endstr)
case 2
s1 = instr(strhtml,startstr)+len(startstr)
s2 = instr(s1,strhtml,endstr)
end select
if err then
strcute = "<p align='center'>没有找到需要的内容。</p>"
err.clear
exit function
else
strcut = mid(strhtml,s1,s2-s1)
end if
end function
function webpagecode(domain)
content=lcase(geturl(domain, "gb2312"))
dim metaexp, matchs, matchess, strhtml
set metaexp = new regexp
metaexp.ignorecase = true
metaexp.global = true
metaexp.pattern = "<meta(.+?)/>"
set matchess = metaexp.execute(content)
for each matchs in matchess
strhtml=strhtml&matchs.value
next
metaexp.pattern = "charset=(.+?)"""
set matchess = metaexp.execute(strhtml)
for each matchs in matchess
strhtml=replace(replace(matchs.value,"charset=",""),"""","")
next
if strhtml="" then
strhtml="gb2312"
end if
webpagecode=strhtml
end function
function webpagesearch(domain, keyword)
dim content, searchtitle, contentlength, keywordbit , responsecontentcount
dim searchinfo, searchurl, searchcontent
if webpagecode(domain)="gb2312" then
content=geturl(domain, "gb2312")
else
content=geturl(domain, webpagecode(domain))
end if
searchtitle=strcut(lcase(content),"<title>","</title>",2)
content=removehtml(content)
contentlength=len(content)
keywordbit=instr(1,lcase(content),keyword,1)
responsecontentcount=70
if contentlength>responsecontentcount*2 then
if clng(keywordbit)-responsecontentcount<0 and clng(keywordbit)+responsecontentcount<=contentlength then
content=left(content,clng(keywordbit)+responsecontentcount)
end if
if clng(keywordbit)>50 and clng(keywordbit)+responsecontentcount<=contentlength then
on error resume next
content=mid(left(content,clng(keywordbit)+responsecontentcount),clng(keywordbit)-responsecontentcount-1)
if err then
err.clear
content=left(content,clng(keywordbit)+responsecontentcount)
end if
end if
end if
content=replace(content,keyword,"<font color=red><b>"&keyword&"</b></font>")
searchtitle=replace(searchtitle,keyword,"<font color=red><b>"&keyword&"</b></font>")
searchinfo="网页内容长度:"&contentlength&" 关健字位置:"&keywordbit
searchcontent=content
searchurl=domain
webpagesearch="<table width=""450"" border=""0"" cellspacing=""0"" cellpadding=""0"">" & _
"<tr><td height=""26"">"&searchinfo&"</td></tr>" & _
"<tr><td height=""26"" class=""title"">" & _
"<a href="&searchurl&" target=""_blank"" class=""title"">" & _
""&searchtitle&"</a></td></tr>" & _
"<tr><td height=""55"" class=""content"" >"& _
" "&searchcontent&"</td></tr>" & _
"<tr><td height=""26"" class=""info"" >" & _
"<a href="&searchurl&" target=""_blank"">"&searchurl&"</a>" & _
" "&date()&"</td>" & _
"</tr></table>"
end function
action=trim(request.form("action"))
if action="true" then
Domains=Trim(Request("Domains"))
Domains=Replace(Domains,vbcrlf,"|")
Domain=split(Domains, "|")
keyword=trim(request.form("keyword"))
For i=0 To Ubound(Domain)
Response.Write(Webpagesearch(Domain(i), keyword)&"<br>")
Next
etimer=timer
if etimer-stimer>1 then
response.write("搜索共用: "&etimer-stimer&" 秒")
else
response.write("搜索共用: 0"&etimer-stimer&" 秒")
end if
End if
'*****************************************
'本程序源创 极限风暴
'*****************************************
%></body></html>
内容来自用户分享和网络整理，不保证内容的准确性，如有侵权内容，可联系管理员处理 
相关文章推荐
- 谈搜索引擎是如何判断文章是否原创
- 站内搜索引擎源代码 asp.net
- [转]ASP.NET网页请求以及处理全过程（反编译工具查看源代码）
- Asp.net 获取网页源代码
- [原创]ASP.net下的前台日历控件源代码(不刷新页面)
- asp.net 下载网页源代码
- asp 网站PR值查询系统源码[绝对原创]
- ASP.NET WAP版 list分页(绝对原创)
- 【吐槽】博客园新的原创文章在搜索引擎的排名不及转载的站点
- asp.net 利用HttpWebRequest自动获取网页编码并获取网页源代码
- asp提供在线文章翻译的功能
- ASP代码获取网页源代码
- [原创]FineUI秘密花园（三十） — ViewState与XState （本系列文章最后一篇，兑现承诺，现提供完整PDF版下载！）
- ASP.NET使用HttpWebRequest读取远程网页源代码
- 用asp.net(c#)获取网页源代码(两种方法)
- 获取网页源代码(Js/Asp)
- asp获取网页源代码并处理乱码的方法
- 用asp.net c# 获取网页源代码