Crawl Web forum email Address section of the code

Crawl Web forum Email Address section of the code

/**

Author: Ci Qin Qiang

Email: cqq1978@gmail.com

Http://blog.csdn.net/cqq

**/

Recently, has been thinking about how to publicize our new website,http://www.up114.com .

Search engine optimization is naturally the first choice, but also can not miss the bulk of the mail, although the bulk of the mail by people despise,

However, as long as the selected group of objects, less hair point, should be nothing,: = ——。

So I found some related topics of the forum, many are moving the network forum, now is the need to put the Forum users email address

Collected, online also sell a special tool, but today we have to write a small tool, the same can achieve results.

Code as follows, with Notepad and other text editing tools, save into Dv.vbs

Before using, you need to go to that forum, register a user and log in

How to use: C:\cscript dv.vbs on it.

' Save location for the email address collected

strfile = "D:\email.txt"

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

IStart = 1 ' User ID min value

iend = 1000 ' User ID maximum

For I=istart to Iend


STRURL1 = strURL & "/dispuser.asp?id=" & CStr (i)

strret = OpenURL (STRURL1)

strret = Getmid (Strret, "mailto:", ">") ' This place may need to be flexible to make some changes

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