'搜集 email 地址 VBS 作者 hereson
Dim strFile,srtUrl,instrFile
'正则变量
Dim URLRegExp,MailRegExp,GmailRegExp
URLRegExp = "http://([\w-]+\.)+[\w-]+(/[\w- ./?%&=]*)?" 'URL正则表达式
MailRegExp = "\w+([-+.]\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*" '电子邮件正则表达式
GmailRegExp = "\w+([-+.]\w+)*@gmail.com" 'Gmail的电子邮件正则表达式
instrFile = ""
instrFile = createobject("wscript.shell").currentdirectory
If instrFile<>"" Then
strFile = instrFile+"\email.txt"
Else
strFile = "d:\email.txt"
End If
srtUrl = ""
While srtUrl <> "xxx"
srtUrl = InputBox("请输入要抓取E-Mail地址的URL地址"&vblf&"输入‘xxx’可以退出程序","抓取E-Mail","1")
If srtUrl <> "xxx" Then
If RegExpTestBystr(URLRegExp,srtUrl)<>"未找到匹配。" And IsNumeric(srtUrl)=False Then
strB=myHttpGet(srtUrl,true)
strB=Replace(strB,"<font color=""#cc0033"">","")
strB=Replace(strB,"</font>","")
strB=Replace(strB,"<font color=#C60A00>","")
strA=RegExpTest(GmailRegExp,strB)
call WriteToFile(strFile,strA)
MsgBox("抓取结束")
Else
MsgBox("请输入正确的URL地址"&vblf&"输入‘xxx’可以退出程序")
End If
End If
Wend
'MsgBox("结束")
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 RegExpTest(patrn, strng) 'patrn:需要查找的字符 strng:被查找的字符串
Dim regEx, Match, Matches ' 创建变量。
Set regEx = New RegExp ' 创建正则表达式。
regEx.Pattern = patrn ' 设置模式。'"\w+([-+.]\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*"'
regEx.IgnoreCase = True ' 设置是否区分大小写。
regEx.Global = True ' 设置全程匹配。
Set Matches = regEx.Execute(strng) ' 执行搜索。
For Each Match In Matches ' 循环遍历Matches集合。
RetStr = RetStr & Match.Value & ","
Next
RegExpTest = RetStr
End Function
'替换文本
Function ReplaceTest(patrn, replStr)
Dim regEx, str1 ' 建立变量。
str1 = "The quick brown fox jumped over the lazy dog."
Set regEx = New RegExp ' 建立正则表达式。
regEx.Pattern = patrn ' 设置模式。
regEx.IgnoreCase = True ' 设置是否区分大小写。
ReplaceTest = regEx.Replace(str1, replStr) ' 作替换。
End Function
'Test 方法
Function RegExpTestBystr(patrn, strng)
Dim regEx, retVal ' 建立变量。
Set regEx = New RegExp ' 建立正则表达式。
regEx.Pattern = patrn ' 设置模式。
regEx.IgnoreCase = False ' 设置是否区分大小写。
retVal = regEx.Test(strng) ' 执行搜索测试。
If retVal Then
RegExpTestBystr = "找到一个或多个匹配。"
Else
RegExpTestBystr = "未找到匹配。"
End If
End Function
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 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
Function myHttpGet(sUrl,bText)
Set oXml = CreateObject("Microsoft.XMLHTTP")
'Set oXml = Server.CreateObject("MSXML2.ServerXMLHTTP") '服务器版本的XMLHTTP组件
'理解下面的内容,你可以参考一下MSDN中的MSXML2.ServerXMLHTTP
With oXml
.Open "GET",sUrl,False
.Send
While .readyState <> 4 '等待下载完毕
.waitForResponse 1000
Wend
If bText = True Then
myHttpGet = bytes2BSTR(.responseBody)
Else
myHttpGet = .responseBody
End If
End With
Set oXml = Nothing
End Function