抓取動網論壇 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 = "

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