用XMLHTTP对象抓取网页源代码，拆分数据写入数据库_[XML教程]
dwww.cn 信息采集
<%
Server.ScriptTimeOut=9999999
PageStart=""'抓取开始页
PageEnd=30'抓取结束页
lburl="http://www.tignet.cn/zhaoshang/index.asp?CurPageNum="'列表第一页开始url
pg=cint(request.querystring("pg"))'取得页数
'=========列表分页处理开始=========================
if PageStart="" and pg=0 then'判断是否为第一页
pg=1'第一页直接抓取
list_url="http://www.tignet.cn/zhaoshang/"
elseif PageStart="" and pg<>0 then'设置下一页抓取url
list_url=lburl&pg
elseif PageStart<>"" and pg=0 then
pg=PageStart'设置采集开始页数
list_url=lburl&pg
elseif PageStart<>"" and pg<>0 then
list_url=lburl&pg
end if
' response.Write list_url
' response.End()
'=========截取数据开始=============================
'第一步设置数据
lists="发布信息"'列表截取
listo="【中国虎网】 为医药界"
listxs="留言咨询"'循环链接截取
links=" linko="' target='_blank' >"
'=================内容加字段=======================
companys=""'公司名称
companyo=""
names="padding-bottom:3px;'>"'药品名称
nameo=""
kinds=">类别："'药品类型
kindo=""
times="更新时间："'代理商介绍
timeo=""
Response.Write ""
Response.Write "
=============抓取"&list_url&"信息开始============="
'调用主题函数NewsList
Call NewsList()
'调用转向下一页函数
Call EndPage()
Function NewsList()'获取某类列表代码
strHtml=GetHTTPPage(list_url)'获得html代码
strHtml=strCut(strHtml,lists,listo,1)'获取列表代码
' response.Write strHtml
' response.End()
strHtml=split(strHtml,listxs)'拆分代码
' response.Write strHtml(1)
' response.End()
for i=0 to (ubound(strHtml)-1)'拆分标题，链接地址
newsurl="http://www.tignet.cn"&strCut(strHtml(i),links,linko,2)
' response.Write newsurl
' response.End()
'Get_time=FormatStr(Trim(strCut(strHtml(i),times,timeo,2)))'发布时间
' if FormatStr(strCut(strHtml(i),links,linko,2))<>"" then
' NewsHtml=GetHTTPPage(newsurl)'获取下一步详细内容页面html代码
'' response.Write NewsHtml
'' response.End()
' else
' response.Write "抓取第"&i&"条链接地址失败,不能抓取此项详细内容，程序将跳过此项目！"
' end if
'leibie=FormatStr(Trim(strCut(NewsHtml,kinds,kindo,2)))'采集产品类别
leibie=FormatStr(Trim(strCut(strHtml(i),kinds,kindo,2)))
if leibie<>"" then
company=FormatStr(Trim(strCut(strHtml(i),companys,companyo,2)))'采集公司名称
'ming=replace(FormatStr(Trim(strCut(strHtml(i),names,nameo,2))),"★","")'采集产品名称
ming=FormatStr(Trim(strCut(strHtml(i),names,nameo,2)))'采集产品名称
shijian=replace(FormatStr(Trim(strCut(strHtml(i),times,timeo,2))),"/","-")'发布时间
s1=instr(leibie,"品 ")
s2=len(leibie)
if s1>0 then
bigkind=mid(leibie,1,s1)
kind=mid(leibie,(s1+1),(s2-s1))
else
bigkind=leibie
kind=""
end if
if newsurl<>"" then
set rs=server.CreateObject("adodb.recordset")
sql="select url from Get_zhaoshang where url='"&newsurl&"'"
rs.open sql,conn,1,1
if rs.eof then
'插入数据
SQL="insert into Get_zhaoshang(company,names,bigkind,kind,url,times) values('"&company&"','"&ming&"','"&bigkind&"','"&kind&"','"&newsurl&"','"&shijian&"')"
Conn.execute(SQL)
response.write "
+"&newsurl&"
"
else
response.write "
此条信息已经存在，程序将跳过!"
end if
end if
end if
Next
set strHtml=nothing
Response.Write "
第"&pg&"页信息抓取结束！！！"
End Function
Function GetHTTPPage(Url)'获取Html代码函数
err.clear
On Error Resume Next
dim http
set http=Server.createobject("Microsoft.XMLHTTP")
Http.open "GET",url,false
'HTTP的通信方式，比如GET或是POST '接收XML数据的服务器的URL地址。通常在URL中要指明ASP或CGI程序
'如果是异步通信方式(true)如果是同步方式(false)
Http.send()
'Send方法的参数类型是Variant，可以是字符串、DOM树或任意数据流。
'发送数据的方式分为同步和异步两种。在异步方式下，数据包一旦发送完毕，就结束Send进程，
'客户机执行其他的操作；而在同步方式下，客户机要等到服务器返回确认消息后才结束Send进程
if Http.readystate<>4 then
'0 Response对象已经创建，但XML文档上载过程尚未结束
'1 XML文档已经装载完毕
'2 XML文档已经装载完毕，正在处理中
'3 部分XML文档已经解析
'4 文档已经解析完毕，客户端可以接受返回消息
exit function
end if
GetHTTPPage = bytesToBSTR(Http.responseBody,"GB2312")'bytesToBSTR 编码转化函数
'=======对Http.responseBody的解释=========
'responseText：将返回消息作为文本字符串；
'responseBody：将返回消息作为HTML文档内容；
'responseXML：将返回消息视为XML文档，在服务器响应消息中含有XML数据时使用；
'responseStream：将返回消息视为Stream对象
'response.write GetHTTPPage
set http = Nothing
If Err Then
response.write err.description
Response.Write "
无法抓取本页面列表信息！！！
"
End If
End function
Function EndPage()'抓取下一页,跳转函数.PageNo--->抓取的页数
if pg response.write ""
else
Response.Write "
"
response.write "===============================信息抓取完毕!!!================================"
response.end
end if
End Function
%>
下面是fget.asp里两个函数，一个是截取，一个事过滤html：
1：截取函数：
Function strCut(strContent,StartStr,EndStr,CutType)
'strContent 要截取的内容
'StartStr 开始标志字符
'EndStr 结束标志字符
'CutType 截取类型 1--包括开始，结尾标记 2----不包括开始，结尾标记
Dim strHtml,S1,S2
strHtml = strContent
On Error Resume Next
If CutType=2 Then'不包括开始，结尾标记
S1 = InStr(strHtml,StartStr)+Len(StartStr)
S2 = InStr(S1,strHtml,EndStr)
If Err Then
response.write "Unknow Wrong:"&err.description&"---BG:" & S1 & " End:"&S2&"
"
Err.Clear
strCut=""
Exit Function
Else
If S1>Len(StartStr) and S2>0 then
strCut=Mid(strHtml,S1,S2-S1)
Else
strCut=""
End If
End if
' response.Write strCut
' response.End()
Else'包括开始，结尾标记
S1 = InStr(strHtml,StartStr)
S2 = InStr(S1,strHtml,EndStr)+Len(EndStr)
If Err Then
response.write "Unknow Wrong:"&err.description&"---BG:" & S1 & " End:"&S2&"
"
Err.Clear
strCut=""
Exit Function
Else
If S1>0 and S2>Len(EndStr) then
strCut=Mid(strHtml,S1,S2-S1)
Else
strCut=""
End If
End if
End If
End Function
2.html过滤函数，也过滤一些 回车，空格之类的
Function FormatStr(str)
Dim s1,s2
If str<>"" then
str=replace(replace(Trim(str),chr(32)&chr(32),""),chr(9),"")
DO While (instr(str,">")>0 and instr(str,"<")>0)
s1=InStr(str,"<")
s2=Instr(s1,str,">")
If s1>0 and s2>0 then
str=replace(str,mid(str,s1,s2-s1+1),"")
End if
Loop
str=replace(replace(str,"<","<"),">",">")
str=Replace(Replace(Replace(replace(replace(str,chr(13),""),chr(10),""),"""","”"),"'","’")," ","")
FormatStr=str
Else
FormatStr=""
End if
End Function
来源:csdn