最近的网络营销培训中,因为谈及了邮件营销的话题,自然引出了邮件抓取的问题,于是将自己多年前用的一款自己开发的邮件抓取工具拿出来给大家共享。
在共享之前,习惯性的把代码阅读了一下,就像所有程序员一样,总会觉得过去自己的代码写的不够好,比如对正则表达式的应用就不够好,于是做了稍许的更改,太多更改也没有时间了,顺便把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 ' 创建正则表达式。