１.抓取一個遠程網(wǎng)頁并保存到本地 '用于調試的過程，后面會多次調用檢查中間結果 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 '功能： 把文本或字節(jié)流保存為文件 '參數(shù)： 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
關鍵的函數(shù) '函數(shù)： myHttpGet '功能： 抓取一個遠程文件（網(wǎng)頁或圖片等）并保存到本地 '參數(shù)： sUrl 遠程文件的URL ' bText 是否是文本（網(wǎng)頁），下載遠程圖片是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
改進：處理亂碼 直接讀取服務器返回的中文內容會出現(xiàn)亂碼，myHttpGet函數(shù)中引用的bytes2BSTR的作用是正確讀取服務器返回的文件中的雙字節(jié)文本（比如說中文） 'myHttpGet helper 處理雙字節(jié)文本 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函數(shù)的功能也可以利用Adodb.Stream組件通過下面的函數(shù)實現(xiàn)，雖然下面的函數(shù)可以指定字符集Charset,但它并不能轉換編碼，即傳遞"UTF-8"給參數(shù)sCset，來讀取一張GB2312編碼的網(wǎng)頁將顯示為亂碼。 '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
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,sPrecedingSaveFileName) Next
ProcessRemoteUrl=sContent End Function 改進：探測真實URL 上面的ProcessRemoteUrl函數(shù)不能正確處理形如img src="upload/abc.jpg" />和a href="/upload/abc.gif" ...的內容，要處理這些相對鏈接，我們可以先用下面的函數(shù)把網(wǎng)頁中的相對鏈接都轉換成絕對鏈接 '函數(shù)： DetectUrl '功能： 替換字符串中的遠程文件相對路徑為以http://..開頭的絕對路徑 '參數(shù)： sContent 要處理的含相對路徑的網(wǎng)頁的文本內容 ' sUrl 所處理的遠程網(wǎng)頁自身的URL，用于分析相對路徑 '返回： 替換相對鏈接為絕對鏈接之后的新的網(wǎng)頁文本內容 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 正則表達式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)"="""sAbsoluteUrlRemoteFileUrl.SubMatches(1)"""" sContent=Replace(sContent,RemoteFileUrl,sAbsoluteUrl) Next
DetectUrl=sContent End Function 改進：避免重復下載 網(wǎng)頁中的有些圖片，比如spacer.gif重復出現(xiàn)，會被重復下載，壁免這個問題的一個方法是設置一個arrUrls數(shù)組，把采集過的文件的URL放在里面，在每次采集前先遍歷數(shù)組看是否已經(jīng)采集，然后只參集沒有參集過的文件
二是你可能不想在對方的服務器上留下連續(xù)的瀏覽記錄，下面的一個小函數(shù)會有所幫助 '過程： Sleep '功能： 程序在此晢停幾秒 '參數(shù)： iSeconds 要暫停的秒數(shù) 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
