开发学院WEB开发ASP 抓取动网论坛Email地址的一段代码 阅读

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

 2005-07-24 10:31:03 来源:WEB开发网   
核心提示:抓取动网论坛 Email 地址的一段代码/**作者: 慈勤强Email : cQQ1978@Gmail.comhttp://blog.csdn.net/cqq**/最近,一直想着怎么宣传我们的新网站,抓取动网论坛Email地址的一段代码,http://www.up114.com ,搜索引擎优化自然是首选,保存成 dv.

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

Tags:抓取 论坛 Email

编辑录入:爽爽 [复制链接] [打 印]
[]
  • 好
  • 好的评价 如果觉得好,就请您
      0%(0)
  • 差
  • 差的评价 如果觉得差,就请您
      0%(0)
赞助商链接