抓取动网论坛 Email 地址的一段代码

　　/**

　　作者： 慈勤强

　　Email : cqq1978@gmail.com

　　http://blog.csdn.net/cqq

　　**/

　　
　　最近，一直想着怎么宣传我们的新网站，http://www.up114.com 。

　　搜索引擎优化自然是首选，可是也不能放过邮件群发，虽然邮件群发被人所不齿，

　　不过，只要选定了群发的对象，少发点，应该没什么吧，：=——。

　　
　　所以就找了一些相关主题的论坛，好多都是动网的论坛，现在就是需要把论坛用户的Email地址

　　收集下来，网上也有卖专门的工具，不过今天我们就自己写个小工具，同样能够达到效果。

　　
　　代码如下， 用记事本等文本编辑工具，保存成 dv.vbs

　　在使用之前，需要你先到那个论坛，注册个用户然后登陆进去

　　
　　使用方法： c:cscript dv.vbs 就可以了。

　　
　　'搜集的 email 地址的保存位置

　　strFile = "d:email.txt"

　　srtUrl = "http://bbs.aaa.com"

　　iStart = 1   '用户ID最小值

　　iEnd = 1000   '用户ID最大值

　　For i=iStart to iEnd
　　 
　　 
　　 strUrl1 = strUrl & "/dispuser.asp？id=" & cstr(i)

　　 strRet = OpenUrl(strurl1)
　　 
　　 strRet = getMid(strRet,"mailto:",">")  '这个地方可能需要灵活做一些改变

　　 If i mod 100=0 then
　　  call WriteToFile(strFile,strA)
　　  strA = ""
　　 else
　　  if strRet<>"" then  strA = strA & strRet & vbCrLf
　　 end if
　　 
　　 Wscript.Echo i & vbTab & strRet

　　Next

　　
　　Sub WriteToFile(strFile,str)
　　   Dim fso, f
　　   Set fso = CreateObject("Scripting.FileSystemObject")
　　   Set f = fso.OpenTextFile(strfile, 8, True)
　　   f.Write str
　　   set f= nothing
　　   set fso=nothing
　　End Sub

　　
　　Function bytes2BSTR(vIn)
　　 Dim i
　　 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

　　
　　Function OpenUrl(strUrl)
　　 
　　 on Error Resume Next

　　   Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
　　 xmlhttp.open "GET",(strUrl ),false
　　    xmlhttp.send    
　　 OpenUrl=bytes2BSTR(xmlhttp.ResponseBody)
　　 
　　    Set xmlhttp = Nothing   
　　End Function  

　　Function getMid(str, str1, str2)
　　 Dim i
　　 Dim j
　　    str11 = ""
　　    i = InStr(str, str1)
　　    If i > 0 Then
　　        j = InStr(i, str, str2)
　　        If j > 0 Then
　　            str11 = Mid(str, i + Len(str1), j - i - Len(str1))       
　　        End If   
　　    End If   
　　    getMid = str11
　　End Function