A piece of code that grabs the email address of Dongwang Forum

A piece of code to capture the email address of Dongwang Forum

/**

Author: Ci Qinqiang

Email: [email protected]

http://blog.csdn.net/cqq

**/

Recently, I have been thinking about how to promote our new website, http://www.up114.com .

Search engine optimization is naturally the first choice, but you can’t let go of mass mailing. Although mass mailing is despised,

as long as you select the target of the mass mailing and send less, it should be fine, :=——.

So I found some forums on related topics, many of which are Dongwang forums. Now I need to

collect the email addresses of forum users. There are also special tools sold online, but today we will write a small tool ourselves, which can also achieve the same goal. Effect.

The code is as follows. Use text editing tools such as Notepad to save it as dv.vbs.

Before using it, you need to go to the forum, register as a user and log in.

Usage: c:cscript dv.vbs is fine.

'The storage location of the collected email addresses

strFile = "d:email.txt"

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

iStart = 1 'Minimum value of user ID

iEnd = 1000 'Maximum value of user IDFor

i= iStart to iEnd


strUrl1 = strUrl & "/dispuser.asp?id=" & cstr(i)

strRet = OpenUrl(strurl1)

strRet = getMid(strRet,"mailto:",">") 'This place may need to be flexibly changed.

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
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