用xmlhttp编写web采集程序

晰带语法着色的版本：

原创很辛苦，转载请注明原文链接：

web采集程序？网页抓取程序？小倫程序？不管怎么叫，这种程序应用倒是蛮广的。本文不讨论这种使用这种程序引起的版权或道德问题，只谈这种程序在asp+vbscript环境下的实现 :-)

预备知识：除了一般的asp+vbscript的知识外，你还需要了解xmlhttp对象和正则表达式对象。xmlhttp对象是时下风头正劲的ajax的主角；而学好了正则表达式，你再也不用为处理复杂的字符串犯愁。

在编写和调试正则表达式时，regex 这个小工具非常有用。

目录
抓取一个远程网页并保存到本地 
改进：处理乱码 
同时下载远程网页的图片（和其它文件） 
改进：探测真实url 
改进：避免重复下载 
实战举例（以****为例） 
分析列表页 
内容页的技巧 
分析内容页中的上一页，下一页 
高级主题：utf-8和gb2312的转换 
更多高级主题：登陆后抓取，客户端伪造 
己有的采集程序 
原文链接：

１.抓取一个远程网页并保存到本地
'用于调试的过程，后面会多次调用检查中间结果
dim indebug:indebug=true 
sub d(str)
    if indebug = false then exit sub
    response.write("<div style='color:#003399; border: solid 1px #003399; background: #eef7ff; margin: 1px; font-size: 12px; padding: 4px;'>")
    response.write(str &"</div>")
    response.flush()
end sub

'过程： save2file
'功能： 把文本或字节流保存为文件
'参数： scontent    要保存的内容
'       sfile       保存到文件，形如"files/abc.htm"
'       btext       是否是文本
'       boverwrite  是否覆盖己存在文件
sub save2file(scontent,sfile,btext,boverwrite)
    call d("save2file:"+sfile+" *是否文本："&btext)
    dim saveoption,typeoption
    if (boverwrite = true) then saveoption=2 else saveoption=1
    if (btext = true) then typeoption=2 else typeoption=1
    set ads = server.createobject("adodb.stream")
    with ads
        .type = typeoption 
        .open
        if (btext = true) then .writetext scontent else .write scontent
        .savetofile server.mappath(sfile),saveoption
        .cancel()
        .close()
    end with
    set ads=nothing
end sub

关键的函数
'函数： myhttpget
'功能： 抓取一个远程文件（网页或图片等）并保存到本地
'参数： surl    远程文件的url
'       btext   是否是文本（网页），下载远程图片是btext=false
'返回： 抓取的内容
function myhttpget(surl,btext)
    call d("<font color=red>myhttpget:</font>"+surl+" *是否文本："&btext)
    'set oxml = server.createobject("microsoft.xmlhttp")
    set oxml = server.createobject("msxml2.serverxmlhttp")  '服务器版本的xmlhttp组件
    '理解下面的内容，你可以参考一下msdn中的msxml2.serverxmlhttp
    with oxml
        .open "get",surl,false
        .send
        while .readystate <> 4  '等待下载完毕
            .waitforresponse 1000 
        wend 
        if btext = true then
            myhttpget = bytes2bstr(.responsebody)
        else
            myhttpget = .responsebody
        end if
    end with
    set oxml = nothing
end function

改进：处理乱码
直接读取服务器返回的中文内容会出现乱码，myhttpget函数中引用的bytes2bstr的作用是正确读取服务器返回的文件中的双字节文本（比如说中文）
'myhttpget helper 处理双字节文本
function bytes2bstr(vin)
    strreturn = ""
    for i = 1 to lenb(vin)
        thischarcode = ascb(midb(vin,i,1))
        if thischarcode < &h80 then
            strreturn = strreturn & chr(thischarcode)
        else
            nextcharcode = ascb(midb(vin,i+1,1))
            strreturn = strreturn & chr(clng(thischarcode) * &h100 + cint(nextcharcode))
            i = i + 1
        end if
    next
    bytes2bstr = strreturn
end function

bytes2bstr函数的功能也可以利用adodb.stream组件通过下面的函数实现，虽然下面的函数可以指定字符集charset,但它并不能转换编码，即传递"utf-8"给参数scset，来读取一张gb2312编码的网页将显示为乱码。
'charsethelper可以正确的读取以scset（如"gb2312","utf-8"等）编码的文件
function charsethelper(arrbytes,scset)
    call d("charsethelper: "+scset)
    dim oados
    set oados = createobject("adodb.stream")
    with oados
        .type = 1
        .mode =3    'admodereadwrite
        .open
        .write arrbytes
        .position = 0
        .type = 2
        .charset = scset
        charsethelper = .readtext 
        .close
    end with
    set oados = nothing
end function

２.同时下载远程网页的图片（和其它文件）
'函数： processremoteurl
'功能： 替换字符串中的远程文件为本地文件并保存远程文件
'参数： strcontent  要替换的字符串，即远程网页文件的内容
'       ssavepath   不以／结尾的相对路径,指示远程文件的本地保存路径
'       spreceding  更改后的url前缀,如
'返回： 替换远程路径为本地路径之后的新的网页文本内容
function processremoteurl(scontent,ssavepath,spreceding)
    call d("processremoteurl")

set re=new regexp
    re.ignorecase =true
    re.global=true
    '下面的正则中.submatches(4)=文件名全名.submatches(5)文件扩展名
    re.pattern = "((http):(?:\/\/){1}(?:(?:\w)+[.])+(net|com|cn|org|cc|tv|[0-9]{1,4})(\s*\/)((?:\s)+[.]{1}(gif|jpg|jpeg|png|bmp)))"

set remotefile = re.execute(scontent)

dim savefilename
    'remotefile     正则表达式match对象的集合
    'remotefileurl  正则表达式match对象
    for each remotefileurl in remotefile
        savefilename = remotefileurl.submatches(4)
        call save2file(myhttpget(remotefileurl,false),ssavepath&"/"&savefilename,false,true)
        scontent=replace(scontent,remotefileurl,spreceding&savefilename)
    next

processremoteurl=scontent
end function 
改进：探测真实url
上面的processremoteurl函数不能正确处理形如<img src="upload/abc.jpg" />和<a href="/upload/abc.gif" ...的内容，要处理这些相对链接，我们可以先用下面的函数把网页中的相对链接都转换成绝对链接
'函数： detecturl
'功能： 替换字符串中的远程文件相对路径为以开头的绝对路径
'参数： scontent    要处理的含相对路径的网页的文本内容
'       surl        所处理的远程网页自身的url，用于分析相对路径
'返回： 替换相对链接为绝对链接之后的新的网页文本内容
function detecturl(scontent,surl)
    call d("detecturl:"&surl)

'分析url
    dim re,smatch
    set re=new regexp
    re.multiline=true
    re.ignorecase =true
    re.global=true

re.pattern = "([-a-z0-9.]+)/[-a-z0-9+&@#%~_|!:,.;/]+/"
    dim shost,spath
    '
    set smatch=re.execute(surl)
    '
    shost=smatch(0).submatches(0)
    '/get/
    spath=smatch(0)

re.pattern = "(src|href)=""?((?!)[-a-z0-9+&@#%=~_|!:,.;/]+)""?"
    set remotefile = re.execute(scontent)

'remotefile 正则表达式match对象的集合
    'remotefileurl 正则表达式match对象,形如src="upload/a.jpg"
    dim sabsoluteurl
    for each remotefileurl in remotefile
        '<img src="a.jpg">,<img src="f/a.jpg">,<img src="/ff/a.jpg">
        if left(remotefileurl.submatches(1),1)="/" then
            sabsoluteurl=shost
        else
            sabsoluteurl=spath
        end if
        sabsoluteurl = remotefileurl.submatches(0)&"="""&sabsoluteurl&remotefileurl.submatches(1)&""""
        scontent=replace(scontent,remotefileurl,sabsoluteurl)
    next

detecturl=scontent
end function 
改进：避免重复下载
网页中的有些图片，比如spacer.gif重复出现，会被重复下载，壁免这个问题的一个方法是设置一个arrurls数组，把采集过的文件的url放在里面，在每次采集前先遍历数组看是否已经采集，然后只参集没有参集过的文件

３.实战举例（以****为例）
****是我最经常去的地方，而且网速不错，就以她为例啦，没有恶意哦:-)

分析列表页
内容页的技巧
分析内容页中的上一页，下一页
想了一下，这部分内容还是晢时不写，免得被ｂｓ了  :-),还省得打好多字。 无非是把远程网页采集下来，然后用正则表达式分析提取其中的特定内容，如标题，作者，内容之类的 我有两个小小的经验：

一是网页源码前后的内容对分析有很大的干扰，你可以用下面的方法先把它支除
'抽取部分内容进行分析，你可以用用editplus数字数
'去除前7600和后5000的字符
spagew=left(spagew,len(spagew)-5000)
spagew=mid(spagew,7600)

二是你可能不想在对方的服务器上留下连续的浏览记录，下面的一个小函数会有所帮助
'过程： sleep
'功能： 程序在此晢停几秒
'参数： iseconds    要暂停的秒数
sub sleep(iseconds)
    d timer()&" <font color=blue>sleep for "&iseconds&" seconds</font>"
    dim t:t=timer()
    while(timer()<t+iseconds)
        'do nothing
    wend
    d timer()&" <font color=blue>sleep for "&iseconds&" seconds ok</font>"
end sub

'调用举例，晢停,时长随机，在3秒以内
sleep(fix(rnd()*3))

三就是多用正则表达式测试工具提高编写正则表达式的效率

４.高级主题：utf-8和gb2312的转换
这个问题比较复杂，由于我智力和精力方面的原因没有完全搞定，网上己有的资料也大多不完全正确或者不全面，我推荐一个utf-8和gb2312的转换的ｃ语言的实现供大家参考，它功能完整而且不依赖windows api函数。
我在试着用asp+vbscript实现它，有一些不太成熟的经验：

计算机上的文件、操作系统内部的字符串表示都是unicode的，所以，utf-8和gb2312之间的转换需要以unicode为中介 
utf-8就是unicode的一个变体，它们之间的相互转换比较简单，参考下图就可以了 
gb2312和unicode的编码好像是不相关的，不依赖操作系统内部函数进行转换就需要一个编码映射表，指出gb2312和unicode的编码一一对应的关系，这个编码表大约包含7480×２个项目。 
在asp文件中，要默认以某和编码(如gb2312)读取一个字符串，需要将asp的codepage设为相应代码页（对gb2312是codepage=936） 
编码转换中还有一些又小又重要的问题我还不知道:-( 
５.更多高级主题：登陆后抓取，客户端伪造等
xmlhttp对象可以以post或get的方法与http服务器交互，可以设置和读取http头，学习一下http协议，并且更深入的了解一些xmlhttp对象的方法和属性，你就可以用它来模拟一个浏览器，自动的做各种以前需要人来做的重复工作。

６.己有的采集程序
本文旨在讨论采集程序在asp+vbscript环境下的实现，如果你需要一个网页采集程序，下面的链接可能对你有用。

locoyspider火车头网页内容采集器 
c#+.net编写的内容采集器，它的一个重要特点是不将采集来的内容保存到数据库，而是使用自定的post提交的别的网页，如内容管理系统的新建内容页。免费。 
beecollector (小蜜蜂采集器) 
php+mysql编写的内容采集器。 
风讯内容管理系统 
这个强大的内容管理系统内带有一个asp的网页内容采集器