【www.hzclsc.cn--模拟经营】

以vb6为例,获取给定的网址的外链的链接地址和链接文本,这里过滤了网站本身的网址,还有一些客服代码
也可以以常见的搜索引擎蜘蛛模拟访问
VB6需要引用 :在“项目”菜单上单击“引用“Microsoft VBScript Regular Expressions 5.5


Public Function HtmlGetLinks(url, zhizu) " 从网址内获取外链地址 参数:网址,蜘蛛类型
  "On Error Resume Next
  Dim str, reg, objMatches, key1
  url2 = Replace(url, "http://", "")
  url = "http://" url2
  str = GetUrlHtmlUTF(url, "auto", zhizu)
  Set reg = New RegExp
  reg.IgnoreCase = True
  reg.Global = True
  reg.Pattern = "href=[\""\"\s]?http://([^\s]+)(.*?)\b[\""\"\s]?(.*?) (.*?) /a "
  Set objMatches = reg.Execute(str)
  If objMatches.Count 0 Then
  For i = 0 To objMatches.Count - 1
  url1 = objMatches(i).SubMatches(0)
  url1 = Replace(url1, """", "")
  url1 = Replace(url1, """, "")
  Keyword = objMatches(i).SubMatches(3)
  Keyword = LCase(Keyword)
  Keyword = Replace(Keyword, """, """")
  If InStr(Keyword, "src") 0 Then
  Keyword = FindStrMulti(Keyword, "src=""", """", "")
  Keyword = "图片:" Keyword
  Else
  Keyword = RemoveHTML(Keyword)
  End If
  If InStr(url1, url2) = 0 And InStr(Keyword, "wpa.qq.com") = 0 And InStr(url1, "51.la") = 0 And InStr(url1, "cnzz.com") = 0 And InStr(url1, "taobao.com") = 0 And InStr(url1, "beian.gov.cn") = 0 Then
  key1 = key1 (Keyword "|" url1) vbCrLf
  End If
  DoEvents
  Next
  End If
  HtmlGetLinks = key1
End Function

Public Function GetUrlHtmlUTF(url, CodeBase, zhizu)
  Dim xmlHTTP1, GetCode, GetCode1
  Set xmlHTTP1 = CreateObject("Microsoft.XMLHTTP")
  xmlHTTP1.Open "get", url, True
  If zhizu "" Then
  Select Case zhizu
  Case "baidu"
  xmlHTTP1.setRequestHeader "UserAgent:", "Baiduspider+(+http://www.baidu.com/search/spider.htm)"
  Case "google"
  xmlHTTP1.setRequestHeader "UserAgent:", "Mozilla/5.0 (compatible; Googlebot/2.1; +http://www.google.com/bot.html)"
  Case "yahoo"
  xmlHTTP1.setRequestHeader "UserAgent:", "Mozilla/5.0 (compatible; Yahoo! Slurp China; http://misc.yahoo.com.cn/help.html)"
  Case "yahoo"
  xmlHTTP1.setRequestHeader "UserAgent:", "Mozilla/5.0 (compatible; Yahoo! Slurp China; http://misc.yahoo.com.cn/help.html)"
  Case "youdao"
  xmlHTTP1.setRequestHeader "UserAgent:", "Mozilla/5.0 (compatible; YodaoBot/1.0; http://www.yodao.com/help/webmaster/spider/; )"
  Case "soso"
  xmlHTTP1.setRequestHeader "UserAgent:", "Sosospider+(+http://help.soso.com/webspider.htm)"
  Case "sogou"
  xmlHTTP1.setRequestHeader "UserAgent:", "Sogou web spider/4.0(+http://www.sogou.com/docs/help/webmasters.htm#07)"
  End Select
  End If
  xmlHTTP1.send
  While xmlHTTP1.ReadyState 4
  DoEvents
  Wend
  GetCode = xmlHTTP1.ResponseBody
  If CodeBase = "auto" Then
  GetCode1 = StrConv(Left(GetCode, 500), vbUnicode)
  If InStr(GetCode1, "charset=gb2312") 0 Then
  GetCode = StrConv(GetCode, vbUnicode)
  Else
  If CStr(GetCode) "" Then GetCode = BytesToBstr(GetCode, "UTF-8")
  End If
  Else
  If CStr(GetCode) "" Then GetCode = BytesToBstr(GetCode, CodeBase)
  End If
 
  GetUrlHtmlUTF = GetCode
  Set ObjXML = Nothing
End Function

本文来源：http://www.hzclsc.cn/danjiyouxi/41782.html