Mail抓取.VBS

'搜集 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