现在的位置: 网页制作教程＞网站制作教程＞正文

asp查看对方网站是否有本站友情链接的代码

发表于2020/10/14 D 网站制作教程 D 0条评论 D 热度 3,632℃

我们在和别的站长成功交换友情链接后，为了防止站长私自下掉友链，特地用asp程序开发了可以检测对方网站是否有本站的友情链接。

下面是具体代码：

<%
' 查看远程页面是否包含本站内容/或友情链接检验程序
' @author webym
' @copyright www.webym.net
' @update 2020/10/14 19:21
Dim webym_url,remote_url,Cset,get_list,get_content
webym_url="www.ae256.com"'自己的网址
remote_url="https://www.webym.net"'要检查的目标网址
Cset="GB2312"'转换后的编码格式
' 获取远程页面内容
get_list=GetBody(remote_url)
' 用GetBody函数获取数据,以GB2312编码格式转换
get_content=BytesToBstr(get_list,Cset)
If InStr(get_content,webym_url)<>0 Then
  response.write "有链接"
Else
  response.write "无链接"
End If
'转换成需要的编码格式
Function BytesToBstr(contentview,Cset) '转换成需要的编码格式
  dim objstream
  set objstream = Server.CreateObject("adodb.stream")
  objstream.Type = 1
  objstream.Mode =3
  objstream.Open
  On Error Resume Next
  objstream.Write contentview
  objstream.Position = 0
  objstream.Type = 2
  objstream.Charset = Cset
  BytesToBstr = objstream.ReadText
  objstream.Close
  set objstream = nothing
End Function
'XMLHTTP组件获取数据
Function GetBody(weburl)
  '创建对象
  Dim Retrieval
  Set Retrieval = CreateObject("Microsoft.XMLHTTP")
  With Retrieval
  Retrieval.Open "Get", weburl, False
  On Error Resume Next
  Retrieval.Send
  'On Error Resume Next
  GetBody = Retrieval.ResponseBody
  End With
  'On Error Resume Next
  If Retrieval.Status<>200 then
  Set Retrieval=Nothing
  Exit function
  End if 
'释放对象
  Set Retrieval = Nothing
End Function
' 以上代码执行后,会显示成 有链接
%>

如果对方网站有自己的目标网址，则显示有链接，反之显示无链接。

声明:如需转载，请注明来源于www.webym.net并保留原文链接：http://www.webym.net/jiaocheng/1111.html