抓取动网论坛 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