抓取动网论坛EMAIL地址的一段代码
类别: ASP教程
搜索引擎优化自然是首选,可是也不能放过邮件群发,虽然邮件群发被人所不齿,
不过,只要选定了群发的对象,少发点,应该没什么吧,:=――。
所以就找了一些相关主题的论坛,好多都是动网的论坛,现在就是需要把论坛用户的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
不过,只要选定了群发的对象,少发点,应该没什么吧,:=――。
所以就找了一些相关主题的论坛,好多都是动网的论坛,现在就是需要把论坛用户的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
- 上一篇: ASP上两个防止SQL注入式攻击FUNCTION
- 下一篇: 一个免费的邮件列表源程序(三)
-= 资 源 教 程 =-
文 章 搜 索