源码网,源码论坛,源码之家,商业源码,游戏源码下载,discuz插件,棋牌源码下载,精品源码论坛

 找回密码
 立即注册
查看: 497|回复: 24

[ASP编程] 写了段批量抓取某个列表页的东东

[复制链接]

7万

主题

861

回帖

32万

积分

论坛元老

Rank: 8Rank: 8

积分
329525
发表于 2006-6-26 00:00:00 | 显示全部楼层 |阅读模式
有些人当抓取程序是个宝,到目前还TND有人在卖钱,强烈BS一下这些家伙 真是的!可能偶下边这段东西比较烂哈
下边这个没有写入库功能,已经到这一步了,入库功能是很简单的事了,需要的请自己去完成吧,其它功能各位自行完善吧!把代码拷贝过去直接运行即可看到效果

Dim Url,List_PageCode,Array_ArticleID,i,ArticleID
Dim Content_PageCode,Content_TempCode
Dim Content_CategoryID,Content_CategoryName,BorderID,ClassID,BorderName,ClassName
Dim 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 = NOTHING
End 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 = 0
End Function

Function RegExpText(strng,strStart,strEnd,n)
    Dim regEx,Match,Matches,RetStr
    SET regEx = New RegExp
    regEx.Pattern = strStart&"([\s\S]*?)"&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=NOTHING
End Function
回复

使用道具 举报

1

主题

2万

回帖

59

积分

注册会员

Rank: 2

积分
59
发表于 2022-9-15 15:40:00 | 显示全部楼层
了乐趣了去了去了去了去了
回复 支持 反对

使用道具 举报

0

主题

2万

回帖

61

积分

注册会员

Rank: 2

积分
61
发表于 2022-10-13 17:23:44 | 显示全部楼层
给爸爸爸爸爸爸爸爸爸爸八佰伴八佰伴
回复 支持 反对

使用道具 举报

0

主题

1万

回帖

0

积分

中级会员

Rank: 3Rank: 3

积分
0
发表于 2022-11-5 00:38:38 | 显示全部楼层
啊啊啊啊啊啊啊啊啊啊啊啊啊啊
回复 支持 反对

使用道具 举报

1

主题

1万

回帖

93

积分

注册会员

Rank: 2

积分
93
发表于 2022-11-11 00:43:34 | 显示全部楼层
sdsadsadsadf
回复 支持 反对

使用道具 举报

匿名  发表于 2022-11-11 03:26:49

太達數位媒體

太達數位媒體



https://deltaamarketing.com.tw/
回复 支持 反对

使用道具

1

主题

2万

回帖

176

积分

注册会员

Rank: 2

积分
176
发表于 2022-11-15 12:06:44 | 显示全部楼层
你们谁看了弄洒了可能
回复 支持 反对

使用道具 举报

27

主题

2万

回帖

331

积分

中级会员

Rank: 3Rank: 3

积分
331
发表于 2023-1-27 17:55:34 | 显示全部楼层
源码源码源码源码源码源码源码源码源码源码源码源码源码
回复 支持 反对

使用道具 举报

3

主题

2万

回帖

163

积分

注册会员

Rank: 2

积分
163
发表于 2023-5-12 12:36:45 | 显示全部楼层
人都不在了啊 啊
TS人妖演出表演服务q3268336102电话13168842816
回复 支持 反对

使用道具 举报

1

主题

1万

回帖

51

积分

注册会员

Rank: 2

积分
51
发表于 2023-10-16 20:24:25 | 显示全部楼层
这个源码还可以
回复 支持 反对

使用道具 举报

高级模式
B Color Image Link Quote Code Smilies

本版积分规则

手机版|小黑屋|网站地图|源码论坛 ( 海外版 )

GMT+8, 2024-11-23 01:14 , Processed in 0.130911 second(s), 26 queries .

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表