写了段批量抓取某个列表页的东东

有些人当抓取程序是个宝，到目前还TND有人在卖钱，强烈BS一下这些家伙真是的！可能偶下边这段东西比较烂哈下边这个没有写入库功能，已经到这一步了，入库功能是很简单的事了，需要的请自己去完成吧，其它功能各位自行完善吧！把代码拷贝过去直接运行即可看到效果 Dim Url,List_PageCode,Array_ArticleID,i,ArticleIDDim Content_PageCode,Content_TempCodeDim Content_CategoryID,Content_CategoryName,BorderID,ClassID,BorderName,ClassNameDim ArticleTitle,ArticleAuthor,ArticleFrom,ArticleContent Url = "http://www.webasp.net/article/class/1.htm"List_PageCode = getHTTPPage(Url)List_PageCode = RegExpText(List_PageCode,"打印</th></tr>","</table><table border=0 cellpadding=5",0)List_PageCode = RegExpText(List_PageCode,"<td align=left><a href='../","'><img border=0 src='../images/authortype0.gif'",1) '取得当前列表页的文章链接，以,分隔Array_ArticleID = Split(List_PageCode,",") '创建数组，存储文章ID For i=0 To Ubound(Array_ArticleID)-1 ArticleID = Array_ArticleID(i) '文章ID Content_PageCode = getHTTPPage("http://www.webasp.net/article/"&ArticleID) '取得文章页的内容 '=========取文章分类及相关ID参数开始======================= Content_TempCode = RegExpText(Content_PageCode,"<a href=""/article/"">技术教程</a> >> ",">> 内容</td>",0) Content_CategoryID = RegExpText(Content_PageCode,"<a href='../class","/'>",1) BorderID = Split(Content_CategoryID,",")(0) '大类ID ClassID = Split(Content_CategoryID,",")(1) '子类ID '==========检查大类是否存在开始=============== '如果不存在则入库 '==========检查大类是否存在结束=============== 'Response.Write(BorderID & "," & ClassID & "<br />") Content_CategoryName = RegExpText(Content_PageCode,"/'>","</a>",1) BorderName = Split(Content_CategoryName,",")(0) '大类名称 ClassName = Split(Content_CategoryName,",")(1) '子类名称 '==========检查子类是否存在开始=============== '如果不存在则入库 '==========检查子类是否存在结束=============== '=========取文章分类及相关ID参数结束======================= '=========取文章标题及内容开始============================= ArticleTitle = RegExpText(Content_PageCode,"<tr><td align=center bgcolor=#DEE2F5><strong>","</strong></td></tr>",0) ArticleAuthor = RegExpText(Content_PageCode,"<tr><td><span class=blue>作者：</span>","</td></tr>",0) ArticleFrom = RegExpText(Content_PageCode,"<tr><td><span class=blue>来源：</span>","</td></tr>",0) ArticleContent = RegExpText(Content_PageCode,"<tr><td class=content style=""WORD-WRAP: break-word"" id=zoom>","</td></tr>"&VBCrlf&" </table>"&VBCrlf&" </td></tr></table>",0) '=========取文章标题及内容结束============================= Response.Write(ArticleTitle& "<br /><br />") Response.Flush()Next 附几个函数： Function getHTTPPage(url) IF(IsObjInstalled("Microsoft.XMLHTTP") = False)THEN Response.Write "<br><br>服务器不支持Microsoft.XMLHTTP组件" Err.Clear Response.End END IF On Error Resume Next Dim http SET http=Server.CreateObject("Msxml2.XMLHTTP") Http.open "GET",url,False Http.send() IF(Http.readystate<>4)THEN Exit Function END IF getHTTPPage=BytesToBSTR(Http.responseBody,"GB2312") SET http=NOTHING IF(Err.number<>0)THEN Response.Write "<br><br>获取文件内容出错" 'Response.End Err.Clear END IF End Function Function BytesToBstr(CodeBody,CodeSet) Dim objStream SET objStream = Server.CreateObject("adodb.stream") objStream.Type = 1 objStream.Mode =3 objStream.Open objStream.Write CodeBody objStream.Position = 0 objStream.Type = 2 objStream.Charset = CodeSet BytesToBstr = objStream.ReadText objStream.Close SET objStream = NOTHINGEnd Function '================================================'作用：检查组件是否已经安装'返回值：True ----已经安装' False ----没有安装'================================================Function IsObjInstalled(objName) On Error Resume Next IsObjInstalled = False Err = 0 Dim testObj SET testObj = Server.CreateObject(objName) IF(0 = Err)THEN IsObjInstalled = True SET testObj = NOTHING Err = 0End Function Function RegExpText(strng,strStart,strEnd,n) Dim regEx,Match,Matches,RetStr SET regEx = New RegExp regEx.Pattern = strStart&"([sS]*?)"&strEnd regEx.IgnoreCase = True regEx.Global = True SET Matches = regEx.Execute(strng) For Each Match in Matches IF(n=1)THEN RetStr = RetStr & regEx.Replace(Match.Value,"$1") & "," ELSE RetStr = RetStr & regEx.Replace(Match.Value,"$1") END IF Next RegExpText = RetStr SET regEx=NOTHINGEnd Function

　　推荐阅读

　　asp打包类

<% On Error Resume Next Dim r Set r = New Rar r.Add Server.MapPath("a.gIf") r.Add Server.MapPath("a.txt") r.Add Server.MapPath("test") r.Add Server.MapPath("file.asp") r.packname = Server.MapPath("x>>>详细阅读

本文标题：写了段批量抓取某个列表页的东东

地址：http://www.17bianji.com/kaifa2/ASP/33244.html

1/2 1