Asp网页搜索引擎，绝对原创，本文章提供源代码

最新推荐文章于 2025-11-22 09:27:18 发布

原创最新推荐文章于 2025-11-22 09:27:18 发布 · 888 阅读

0 ·

CC 4.0 BY-SA版权

文章标签：

#搜索引擎 #asp #domain #action #each #function

asp程序专栏收录该内容

6 篇文章

订阅专栏

实例地址：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"></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>