AUTOGET

XMLHTTP批量抓取远程资料可以在此基础上结合正则表达式做成更好的效果，希望大家能分享一下Xmlhttp的session共享技术 AUTOGET <% '================================================= 'FileName: Getit.Asp 'Intro : Auto Get Data From Remote WebSite 'Author: Babyt(阿泰) 'URL: http://blog.csdn.net/babyt 'createAt: 2002-02 Lastupdate:2004-09 'DB Table : data 'Table Field: ' UID -> Long -> Keep ID Of the pages ' UContent -> Text -> Keep Content Of the Pages(HTML) '================================================= Server.ScriptTimeout=5000 'on error resume next Set conn = Server.createObject("ADODB.Connection") conn.open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("getit.mdb") Set rs = Server.createObject("ADODB.Recordset") sql="select * from data" rs.open sql,conn,1,3 Dim comeFrom,myErr,myCount '======================================================== comeFrom="http://www.xxx.com/U.asp?ID=" myErr1="该资料不存在" myErr2="该资料已隐藏" '======================================================== '*************************************************************** ' 只需要更改这里 i 的始点intMin和终点intMax,设定步长intStep ' 每次区间设置成5万左右。估计要两个多小时。期间不需要人工干预 '**************************************************************** intMin=0 intMax=10000 '设定步长 intStep=100 '========================================================== '以下代码不要更改 '========================================================== Call GetPart (intMin) Response.write "已经转换完成" & intMin & "~~" & intMax & "之间的数据" rs.close Set rs=Nothing conn.Close set conn=nothing %> <% '使用XMLHTTP抓取地址并进次内容处理 Function GetBody(Url) Dim objXML On Error Resume Next Set objXML = createObject("Microsoft.XMLHTTP") With objXML .Open "Get", Url, False, "", "" .Send GetBody = .ResponseBody End With GetBody=BytesToBstr(GetBody,"GB2312") Set objXML = Nothing End Function '使用Adodb.Stream处理二进制数据 Function BytesToBstr(strBody,CodeBase) dim objStream set objStream = Server.createObject("Adodb.Stream") objStream.Type = 1 objStream.Mode =3 objStream.Open objStream.Write strBody objStream.Position = 0 objStream.Type = 2 objStream.Charset = CodeBase BytesToBstr = objStream.ReadText objStream.Close set objStream = nothing End Function '主函数 Function GetPart(iStart) Dim iGo time1=timer() myCount=0 For iGo=iStart To iStart+intStep If iGo<=intMax Then Response.Execute comeFrom & iGo '进行简单的数据处理 content = GetBody(comeFrom & iGo ) content = Replace(content,chr(34),""") If instr(content,myErr1) OR instr(content,myErr2) Then '跳过错误信息 Else '写入数据库 rs.AddNew rs("UID")=iGo '******************************** rs("UContent")=Replace(content,""",chr(34)) '********************************* rs.update myCount=myCount+1 Response.Write iGo & "
" Response.Flush End If Else Response.write "成功抓取"&myCount&"条记录," time2=timer() Response.write "耗时:" & Int(FormatNumber((time2-time1)*1000000,3)) & " 秒
" Response.Flush Exit Function End If Next Response.write "成功抓取"&myCount&"条记录," time2=timer() Response.write "耗时:" & CInt(FormatNumber((time2-time1),3)) & " 秒
" Response.Flush '递归 GetPart(iGo+1) End Function%>