晰帶文法著色的版本：http://gwx.showus.net/blog/article.asp?id=229
原創很辛苦，轉載請註明原文連結：http://gwx.showus.net/blog/article.asp?id=229
web採集程式？網頁抓取程式？小倫程式？不管怎麼叫，這種程式應用倒是蠻廣的。本文不討論這種使用這種程式引起的著作權或道德問題，只談這種程式在ASP+VBScript環境下的實現 :-)
預備知識：除了一般的ASP+VBScript的知識外，你還需要瞭解xmlhttp對象和Regex對象。xmlhttp對象是時下風頭正勁的Ajax的主角；而學好了Regex，你再也不用為處理複雜的字串犯愁。
在編寫和調試Regex時，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
End Function
２.同時下載遠程網頁的圖片（和其它檔案）
'函數： ProcessRemoteUrl
'功能： 替換字串中的遠程檔案為本地檔案並儲存遠程檔案
'參數： strContent 要替換的字串，即遠程網頁檔案的內容
' sSavePath 不以／結尾的相對路徑,指示遠程檔案的本地儲存路徑
' sPreceding 更改後的URL首碼,如yun_qi_img/abc.jpg" />和<a href="/upload/abc.gif" ...的內容，要處理這些相對連結，我們可以先用下面的函數把網頁中的相對連結都轉換成絕對連結
'函數： DetectUrl
'功能： 替換字串中的遠程檔案相對路徑為以
http://..開頭的絕對路徑
'參數： 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 = "(http://[-A-Z0-9.]+)/[-A-Z0-9+&@#%~_|!:,.;/]+/"
Dim sHost,sPath
'http://localhost/get/sample.asp
Set sMatch=re.Execute(sUrl)
'http://localhost
sHost=sMatch(0).SubMatches(0)
'http://localhost/get/
sPath=sMatch(0)
re.Pattern = "(src|href)=""?((?!http://)[-A-Z0-9+&@#%=~_|!:,.;/]+)""?"
Set RemoteFile = re.Execute(sContent)
'RemoteFile RegexMatch對象的集合
'RemoteFileUrl RegexMatch對象,形如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放在裡面，在每次採集前先遍曆數組看是否已經採集，然後只參集沒有參集過的檔案
３.實戰舉例（以****為例）
****是我最經常去的地方，而且網速不錯，就以她為例啦，沒有惡意哦:-)
分析列表頁
內容頁的技巧
分析內容頁中的上一頁，下一頁
想了一下，這部分內容還是晢時不寫，免得被ＢＳ了 :-),還省得打好多字。 無非是把遠程網頁採集下來，然後用Regex分析提取其中的特定內容，如標題，作者，內容之類的 我有兩個小小的經驗：
一是網頁源碼前後的內容對分析有很大的幹擾，你可以用下面的方法先把它支除
'抽取部分內容進行分析，你可以用用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))
三就是多用Regex測試載入器提高編寫Regex的效率
４.進階主題：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的網頁內容採集器
