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

文章整理：站长天空 网址：http://www.z6688.com/
以上信息与文章正文是不可分割的一部分,如果您要转载本文章,请保留以上信息，谢谢!