最近實在是太流行採集了，本人是不喜歡採集的，但對採集的原理我卻很有興趣進行研究，拿到了網上採集常用函數，對其進行了一番研究，並實戰，結果成功，撇開效率問題，採集原理並不複雜，大家可以在搜尋吧輸入“採集”查看其原理。下面是一個採集的例子：
複製代碼 代碼如下:
<%@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,"<cq>","</cq>")
Answer = GetKey(Html,"<ca>","</ca>")
Response.Write(Question&"<br />")
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
%>
