input正则邮箱_邮件抓取中用正则表达式提取邮箱的方法

最近的网络营销培训中，因为谈及了邮件营销的话题，自然引出了邮件抓取的问题，于是将自己多年前用的一款自己开发的邮件抓取工具拿出来给大家共享。

在共享之前，习惯性的把代码阅读了一下，就像所有程序员一样，总会觉得过去自己的代码写的不够好，比如对正则表达式的应用就不够好，于是做了稍许的更改，太多更改也没有时间了，顺便把VB应用正则表达式抓取邮件的方法一起共享在这里，希望对有兴趣的朋友有所帮助。

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,"

color=""#cc0033"">","")

strB=Replace(strB,"

","")

strB=Replace(strB,"

color=#C60A00>","")

strA=RegExpTest(GmailRegExp,strB)

call

WriteToFile(strFile,strA)

MsgBox("抓取结束")

Else

MsgBox("请输入正确的URL地址"&vblf&"输入‘xxx’可以退出程序")

End If

End If

Wend

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

用VB要做些修改，比如：创建正则表达式要：

Set regEx =

CreateObject("VBScript.RegExp") ' 创建正则表达式。

而不能是：

'Set regEx = New

RegExp ' 创建正则表达式。