<!--#include file="fget.asp"--><!--#include file="conn.asp"--><html><head><meta http-equiv="Content-Type" content="text/html; charset=gb2312"><title>信息採集</title></head><body ><% 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="<a href='"'標題鏈接 linko="' target='_blank' >"'=================內容加字段======================= companys="<span style='font-size:12px;'>"'公司名稱 companyo="</span>" names="padding-bottom:3px;'>"'藥品名稱 nameo="</a>" kinds=">類別："'藥品類型 kindo="</span>" times="更新時間："'代理商介紹 timeo="</span>" Response.Write "</br>" Response.Write "<center><font size=3pt>=============抓取"&list_url&"信息開始=============</font></center>"'調用主題函數NewsListCall 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 " <font color=Green size=3pt>+</font>"&newsurl&"<br>" else response.write " <font color=red size=3pt>此條信息已經存在，程序將跳過!</font><br>" end if end if end if Next set strHtml=nothing Response.Write "<center><font size=3pt>第"&pg&"頁信息抓取結束！！！</font></center>"End FunctionFunction 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 "<br><br><p align='center'><font color='red'><b>無法抓取本頁面列表信息！！！</b></font></p>" End IfEnd functionFunction EndPage()'抓取下一頁,跳轉函數.PageNo--->抓取的頁數 if pg<PageEnd Then'抓取下一頁 response.write "<script>window.location='tignetcn.asp?pg="&pg+1&"';</script>" else Response.Write "<hr size=1 color=#00FF00 width=500>" response.write "<center><font size=2pt><b>===============================信息抓取完畢!!!================================</b></font></center>" response.end end ifEnd Function%></body></html> 下面是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&"<br>" 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&"<br>" 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 IfEnd Function2.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