１.抓取一个远程网页并保存到本地 '用于调试的过程，后面会多次调用检查中间结果 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
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函数不能正确处理形如img src="upload/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 正则表达式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 改进：避免重复下载 网页中的有些图片，比如spacer.gif重复出现，会被重复下载，壁免这个问题的一个方法是设置一个arrUrls数组，把采集过的文件的URL放在里面，在每次采集前先遍历数组看是否已经采集，然后只参集没有参集过的文件
二是你可能不想在对方的服务器上留下连续的浏览记录，下面的一个小函数会有所帮助 '过程： 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
