<%
set my_conn= Server.CreateObject("ADODB.Connection")
ConnString = "DRIVER={Microsoft Access Driver (*.mdb)};DBQ=" & Server.MapPath("data/mybu.net.mdb")
my_Conn.Open ConnString
if Request.ServerVariables("HTTP_REFERER")<>off then
url = Request.ServerVariables("HTTP_REFERER")
if url<>"" then
domain=split(url,"/")(2)
b=ubound(split(domain,"."))
if b=1 then
domain="http://www."&domain
else
domain="http://"&domain
end if
if domain<>"http://www.haocom.net" then
weburl=domain
set rrs=server.CreateObject("adodb.recordset")
rsql="select * from Link where Url='"&weburl&"'"
rrs.open rsql,my_conn,1,3
if rrs.eof and rrs.bof then
Function GetHttpPage(HttpUrl)
If IsNull(HttpUrl)=True Then
response.Write("请输入网址！")
Exit Function
End If
Dim Http
Set Http=server.createobject("MSX"&"ML2.XML"&"HTTP")
Http.open "GET",HttpUrl,False
Http.Send()
If Http.Readystate<>4 then
Set Http=Nothing
response.Write("该网页无法访问！")
Exit function
End if
if left(split(bytesToBSTR(Http.responseBody,"UTF-8"),"charset=")(1),6)="gb2312" or left(split(bytesToBSTR(Http.responseBody,"UTF-8"),"charset=")(1),6)="GB2312" then
GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
elseif left(split(bytesToBSTR(Http.responseBody,"UTF-8"),"charset=")(1),3)="gbk" or left(split(bytesToBSTR(Http.responseBody,"UTF-8"),"charset=")(1),3)="GBK" then
GetHTTPPage=bytesToBSTR(Http.responseBody,"GBK")
elseif left(split(bytesToBSTR(Http.responseBody,"UTF-8"),"charset=")(1),5)="utf-8" or left(split(bytesToBSTR(Http.responseBody,"UTF-8"),"charset=")(1),5)="UTF-8" then
GetHTTPPage=bytesToBSTR(Http.responseBody,"UTF-8")
else
GetHTTPPage=bytesToBSTR(Http.responseBody,"gb2312")
end if
Set Http=Nothing
If Err.number<>0 then
Err.Clear
End If
End Function
Function BytesToBstr(Body,Cset)
Dim Objstream
Set Objstream = Server.CreateObject("adod"&"b.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 GetPageTitle(HtmlContent)
Dim l,j,strTitle
l = InStr(LCase(HtmlContent), "")
If l > 0 Then
l = l + 7
j = InStr(l, LCase(HtmlContent), "")
If j > 0 Then
strTemp = Mid(HtmlContent, l, j - l)
Else
strTemp = weburl
End If
Else
strTemp = weburl
End If
GetPageTitle = strTemp
End Function
HtmlCldeContent = getHTTPPage(weburl) '要提取页面的url地址
Title = GetPageTitle(HtmlCldeContent)
set rs=server.CreateObject("adodb.recordset")
sql="select * from Link"
rs.open sql,my_conn,1,3
rs.addnew
rs("Url")=weburl
rs("Title")=title
rs("Time")=now()
rs.update
rs.close
set rs=nothing
else
rrs("Time")=now()
rrs("Num")=rrs("Num")+1
rrs.update
end if
end if
end if
end if
%>
HaoCom,我的最爱
