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

在共享之前，习惯性的把代码阅读了一下，就像所有程序员一样，总会觉得过去自己的代码写的不够好，比如对正则表达式的应用就不够好，于是做了稍许的更改，太多更改也没有时间了，顺便把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,"<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

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            ' 创建正则表达式。

我的工具下载地址是：http://www.xinden.com/download/crabeemail.html  现在的版本是:2.2