auto_add_ok.asp

K风搜索 2.1商业版 完整功能版 后台http://XXXXXX/admin/ 管理帐号：admin 管理密码：admin 安全密码： ks21 网站设置http://XXXXXX/

<!--#include file="../setup.asp"-->
<!--#include file="login_admin.asp"-->
<!--#include file="conn.asp"-->
<%
'================================================================================
'Product:K-Search Version 2.1
'本“软件产品”受《中华人民共和国著作权法》和《中华人民共和国计算机软件保护条例》 
'和国际条约的保护。如未经授权而擅自复制或传播本程序（或其中任何部分），将受到严厉
'的刑事及民事制裁，并将在法律许可的范围内受到最大可能的起诉！
'Homepage：http://www.lucoo.com/
'--------------------------------------------------------------------------------
'Copyright(c) 2005 lucoo.com All Rights Reserved 绿色互联 版权所有
'================================================================================
function filtration(str)
str=replace(str,chr(32),"")
str=replace(str,chr(34),"")
str=replace(str,chr(35),"")
str=replace(str,chr(37),"")
str=replace(str,chr(38),"")
str=replace(str,chr(39),"")
str=replace(str,chr(40),"")
str=replace(str,chr(41),"")
str=replace(str,chr(42),"")
str=replace(str,chr(43),"")
str=replace(str,chr(59),"")
str=replace(str,chr(60),"")
str=replace(str,chr(61),"")
str=replace(str,chr(62),"")
filtration=str
end Function

Server.ScriptTimeOut=90
Function GetURL(url) 
Set Retrieval=Server.CreateObject("Microsoft.XMLHTTP") 
With Retrieval 
.Open "GET",url,False
.Send 
GetURL=bytes2bstr(.responsebody)
End With 
Set Retrieval=Nothing 
End Function

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 = strreturn 
end function 

Dim Url,Html,Title,Keyword,Content
Url=Request.Form("url")
Html=GetURL(Url) 

Dim KSearchRegExp,KSearchMatch
Set KSearchRegExp=New RegExp
KSearchRegExp.IgnoreCase=True  
KSearchRegExp.Pattern="<TITLE>([^<]*)</TITLE>"  
Set KSearchMatch=KSearchRegExp.Execute(HTML)
if NOT KSearchMatch.Count=0 Then 
Title=KSearchMatch.item(0).Value
Title=Replace(Title, "<TITLE>", "", 1, -1, vbTextCompare)
Title=Replace(Title, "</TITLE>", "", 1, -1, vbTextCompare)
end if
set KSearchMatch=Nothing

KSearchRegExp.Pattern="<META[^>]+(name=""keywords""|content=""([^""]*)"")[^>]+(name=""keywords""|content=""([^""]*)"")[^>]*>"
Set KSearchMatch=KSearchRegExp.Execute(HTML)
if NOT KSearchMatch.Count=0 Then 
Keyword=KSearchMatch.item(0).Value
Keyword=Mid(Keyword, InStr(1, Keyword, "content=""", vbTextCompare) + 9)
Keyword=Mid(Keyword, 1, InStr(1,Keyword, """", vbTextCompare) -1)
end if
set KSearchMatch=Nothing

KSearchRegExp.Pattern="<META[^>]+(name=""description""|content=""([^""]*)"")[^>]+(name=""description""|content=""([^""]*)"")[^>]*>"
Set KSearchMatch=KSearchRegExp.Execute(HTML)
if NOT KSearchMatch.Count=0 Then 
Content=KSearchMatch.item(0).Value
Content=Mid(Content, InStr(1,Content, "content=""", vbTextCompare) + 9)
Content=Mid(Content, 1, InStr(1,Content, """", vbTextCompare) -1)   
end if
set KSearchMatch=Nothing
set KSearchRegExp=Nothing

if title="" or instr(title,"无标题")=1 then
Response.Write"此网页不能自动采集!"
end if

if keyword="" then
Keyword=title
end if

if content="" then
Content=title
end if

dim rs,sort_id
sort_id=Request.Form("sort_id")
set rs=server.createobject("adodb.recordset")
rs.open "select * from web where id is null",conn,1,3
rs.addnew
rs("sort_path")=filtration(Request.Form("sort_path"))
rs("sort_id")=sort_id
rs("title")=filtration(left(title,25))
rs("url")=filtration(url)
rs("keyword")=filtration(left(keyword,25))
rs("content")=filtration(left(content,50))
rs("sequence")="0"
rs("commend")="0"
rs("one_click_open")="0"
rs("verify")="0"
rs("click")="0"
rs("time")=date()
rs.update
rs.close
set rs = nothing
response.write "<Script>window.alert('添加成功!');location.replace('auto_add.asp?sort_id="&sort_id&"');</Script>"
%>