抓取动网论坛 Email 地址的一段代码


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

补充：综合编程 , 安全编程 ,