问VBA RegEx在MS中抓取反弹邮件

EN

With RegEx
   yadda yadda yadda
   .Global = True
End With

Sub Bounced_Email_Harvester()
'
' Bounced-Email Text-Process Macro
'
Dim flag As Boolean
' DocLen is to maintain Document length in characters
Dim DocLen As Long
' Try to speed up Word by suspending unnecessary tasks
ActiveDocument.ActiveWindow.View.Draft = True
Options.Pagination = False
Options.CheckGrammarAsYouType = False
Options.CheckSpellingAsYouType = False
Application.ScreenUpdating = False
' Remove extraneous bracket characters < & >
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ">>>"
        .Replacement.Text = "###"
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "<<<"
        .Replacement.Text = "VVV"
        .Forward = True
        .Wrap = wdFindContinue
    End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.WholeStory
DocLen = Len(Selection)
Application.DisplayStatusBar = True
Selection.HomeKey Unit:=wdStory
' CORE OF MACRO IS WITHIN THIS LOOP
Do While DocLen > 800
    ' Selects text until next @ sign is reached - locating email addresses
    flag = True
    While flag = True
        Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        DocLen = DocLen - 1
        If Strings.Right(Selection.Range.Text, 1) = "@" Or DocLen < 2 Then flag = False
        Wend
    flag = True
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    DocLen = DocLen + 1
    While flag = True
        Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        DocLen = DocLen + 1
    'Locate the Beginning of email seeking demarkations (brackets, space, tab, paragraph)
        If Strings.Right(Selection.Range.Text, 1) = "<" Or Strings.Right(Selection.Range.Text, 1) = "[" Or Strings.Right(Selection.Range.Text, 1) = "(" Or Strings.Right(Selection.Range.Text, 1) = " " _
        Or Strings.Right(Selection.Range.Text, 1) = Chr$(9) Or Strings.Right(Selection.Range.Text, 1) = Chr$(13) Or DocLen < 2 Then flag = False
    Wend
    Selection.TypeParagraph
    flag = True
    While flag = True
        Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        DocLen = DocLen - 1
'Locate the End of email seeking demarkations (brackets, space, tab, paragraph)
        If Strings.Right(Selection.Range.Text, 1) = ">" Or Strings.Right(Selection.Range.Text, 1) = "]" Or Strings.Right(Selection.Range.Text, 1) = ")" Or Strings.Right(Selection.Range.Text, 1) = " " _
        Or Strings.Right(Selection.Range.Text, 1) = Chr$(9) Or Strings.Right(Selection.Range.Text, 1) = Chr$(13) Or DocLen < 2 Then flag = False
    Wend
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.Previous(Unit:=wdCharacter, Count:=1).Select
    DocLen = DocLen + 1
    Selection.TypeParagraph
Loop
' END OF CORE MACRO LOOP
Selection.Collapse Direction:=wdCollapseEnd
    Selection.Previous(Unit:=wdCharacter, Count:=1).Select
    Selection.TypeParagraph
' Major work done - now some pesky house cleaning....
Selection.Find.ClearFormatting
With Selection.Find
    .Text = "mailto:"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
    .Text = ":550^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
    .Text = "<^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
    .Text = ";^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
    .Text = "...^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
    .Text = ".^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
    .Text = "^p^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute Replace:=wdReplaceAll
MsgBox ("Count: " & DocLen)
End Sub

Private Sub ListEmailAddresses(outlookItems As Outlook.Items)
  Dim folder As Outlook.MAPIFolder = Nothing
  Try
    Dim emailAddresses As New List(Of String)
    If TypeOf outlookItems.Parent Is Outlook.MAPIFolder Then
      folder = CType(outlookItems.Parent, Outlook.MAPIFolder)
    End If
    For i = 1 To outlookItems.Count
      Dim objItem As Object = outlookItems(i)
      Try
        If TypeOf objItem Is Outlook.ReportItem Then
          Dim rpt As Outlook.ReportItem = TryCast(objItem, Outlook.ReportItem)
          Dim temp() As Byte = System.Text.Encoding.Unicode.GetBytes(rpt.Body.ToArray())
          Dim sb As New System.Text.StringBuilder
          For z As Integer = 0 To temp.Length - 1
            sb.Append(Chr(temp(z)))
          Next
          Dim rptBody As String = sb.ToString
          Dim mc As MatchCollection = Regex.Matches(rptBody, _
                     "([a-zA-Z0-9_\-\.]+)@([a-zA-Z0-9_\-\.]+)\.([a-zA-Z]{2,5})")
          Dim results(mc.Count - 1) As String
          For x As Integer = 0 To results.Length - 1
            Dim emailAddr As String = ValueIfNull(mc(x).Value, "").ToLower
            If Not String.IsNullOrWhiteSpace(emailAddr) Then
              If Not emailAddresses.Contains(emailAddr) Then
                emailAddresses.Add(emailAddr)
              End If
            End If
          Next
        End If
      Catch ex As Exception
        ' Do Something if you care.
      Finally
        Marshal.ReleaseComObject(objItem)
      End Try
    Next
    emailAddresses.Sort()
    Debug.WriteLine(emailAddresses.ToSeparatedString(Environment.NewLine))
  Catch ex As Exception
    ' Do Something if you care.
  Finally
    If folder IsNot Nothing Then Marshal.ReleaseComObject(folder)
  End Try
End Sub