【下载文档:  asp采集实战代码.txt 】

---

asp 采集实战代码
最近实在是太流行采集了，本人是不喜欢采集的，但对采集的原理我却很有兴趣进行研究，拿到了网上采集常用函数，对其进行了一番研究，并实战，结果成功，撇开效率问题，采集原理并不复杂，大家可以在搜索吧输入“采集”查看其原理。下面是一个采集的例子： 复制代码 代码如下:<%@LANGUAGE="VBSCRIPT" CODEPAGE="65001"%> <% Response.CodePage=65001%> <% Response.Charset="UTF-8" %> <%Server.Scripttimeout=9999999 response.expires = 0 response.expiresabsolute = Now() - 1 response.addHeader "pragma","no-cache" response.addHeader "cache-control","private" Response.CacheControl = "no-cache" %> <% '声明取得目标信息的函数,通过XML组件进行实现。 Function GetURL(url) Set Retrieval = server.createobject("MSXML2.XMLHTTP") With Retrieval .Open "GET", url, False .Send If .Status<>200 then '判断文档是否已经解析完，以做客户端接受返回消息 exit function End If ' 二进制转字符串 GetURL = sTb(.responsebody) end with '对取得信息进行验证，如果信息长度小于100则说明截取失败 End Function ' 二进制转字符串，否则会出现乱码的！ Function sTb(vin) Const adTypeText = 2 Dim BytesStream,StringReturn Set BytesStream = Server.CreateObject("ADODB.Stream") With BytesStream .Type = adTypeText .Open .WriteText vin .Position = 0 .Charset = "GB2312" .Position = 2 StringReturn = .ReadText .Close End With Set BytesStream = Nothing sTb = StringReturn End Function Function Newstring(Wstr,Strng) Newstring=Instr(Lcase(Wstr),Lcase(Strng)) If Newstring<=0 Then Newstring=Len(Wstr) End Function '声明截取的格式，从Start开始截取，到Over为结束 Function GetKey(HTML,Start,Over) Start=Newstring(HTML,start) Over=Newstring(HTML,Over) GetKey=Mid(HTML,Start,Over-start) End Function Dim Softid,Url,Html,Title '采集百度知道 For i = 1 to 100 Url="http://zhidao.baidu.com/question/10000"&i&".html" Html = GetURL(Url) Question = GetKey(Html,"","") Answer = GetKey(Html,"","") Response.Write(Question&"
") Response.Write(Answer) Response.Write("采集成功") Next '打开数据库,准备入库 'dim connstr,conn,rs,sql 'connstr="DBQ="+server.mappath("db1.mdb")+";DefaultDir=;DRIVER={Microsoft Access Driver (*.mdb)};" 'set conn=server.createobject("ADODB.CONNECTION") 'conn.open connstr 'set rs=server.createobject("adodb.recordset") 'sql="select [列名] from [表名] where [列名]='"&Title&"'" 'rs.open sql,conn,3,3 'if rs.eof and rs.bof then 'rs("列名")=Title 'rs.update 'set rs=nothing 'end if 'set rs=nothing %>