用xmlhttp编写web采集程序

晰带语法着色的版本：http://gwx.showus.net/blog/article.asp?id=229

原创很辛苦，转载请注明原文链接：http://gwx.showus.net/blog/article.asp?id=229

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

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

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

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

１.抓取一个远程网页并保存到本地
'用于调试的过程，后面会多次调用检查中间结果
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<