抓取動網論壇Email位址的一段程式碼

抓取動網論壇Email 位址的一段程式碼

/**

作者： 慈勤強

Email : [email protected]

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