从 Outlook 退回的电子邮件中提取各种格式的电话号码

Question

我的同事遇到了瓶颈。通过退回的电子邮件更新我们 CRM 中的联系信息。 考虑到许多只是“不在办公室”的电子邮件，他们有很多电子邮件要处理。

这是我到目前为止的完整代码：

'Enable Microsoft Outlook 16.0 Object Library in Tools>>>References
Option Explicit
Sub GetFromOutlook()

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim RowCount As Integer

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Contact Info")

Range("a1").Select
Range("a1").Value = "eMail_subject"
Range("b1").Value = "eMail_date"
Range("c1").Value = "eMail_sender"
Range("d1").Value = "eMail_text"

i = 1

For Each OutlookMail In Folder.Items
    'If OutlookMail.ReceivedTime >= Range("From_date").Value Then
        ActiveCell.Offset(i, 0).Value = OutlookMail.Subject
        ActiveCell.Offset(i, 1).Value = OutlookMail.ReceivedTime
        ActiveCell.Offset(i, 2).Value = OutlookMail.SenderName
        ActiveCell.Offset(i, 3).Value = OutlookMail.Body
        
        i = i + 1
    'End If
Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

RowCount = WorksheetFunction.CountA(Range("a2:a1000000")) + 1


'Creating Cleaned Message Column--------------------
Range("e1").Value = "Cleaned Message"

Range("e2").Select

ActiveCell.FormulaR1C1 = _
    "=TRIM(SUBSTITUTE(SUBSTITUTE(RC[-1],CHAR(13),""""),CHAR(10),""""))"
    
Selection.AutoFill Destination:=Range(ActiveCell, Cells(RowCount, ActiveCell.Column))

Range("e1", Cells(RowCount, ActiveCell.Column)).Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

'Creating Message Status Column---------------------
Range("f1").Value = "Message Status"

Range("f2").Select

ActiveCell.Formula2R1C1 = _
    "=IFS(ISNUMBER(FIND(""retire"",lower(RC[-1]))),""Retired"",ISNUMBER(FIND(""no longer with"",lower(RC[-1]))),""No Longer With"",ISNUMBER(FIND(""no longer employed"",lower(RC[-1]))),""No Longer Employed"",ISNUMBER(FIND(""out of the office"",lower(RC[-1]))),""Out of the office"",ISNUMBER(FIND(""out of office"",lower(RC[-1]))),""Out of the Office"",ISNUMBER(FIND(""vacation"",lower(RC[-1]))),""On Vacation"",ISNUMBER(FIND(""out of the facility"",lower(RC[-1]))),""Out of the Office"",ISNUMBER(FIND(""unavailable"",lower(RC[-1]))),""Out of the Office""" _
    & ",ISNUMBER(FIND(""office will be close"",lower(RC[-1]))),""Office(s) Closed"",ISNUMBER(FIND(""office is closed"",lower(RC[-1]))),""Office(s) Closed"",ISNUMBER(FIND(""offices are closed"",lower(RC[-1]))),""Office(s) Closed"",ISNUMBER(FIND(""unable to respond"",lower(RC[-1]))),""Out of the Office"",ISNUMBER(FIND(""I will be out"",lower(RC[-1]))),""Out of the Office"",ISNUMBER(FIND(""away from my computer"",lower(RC[-1]))),""Away From Computer"",ISNUMBER(FIND(""away from computer"",lower(RC[-1]))),""Away From Computer"",ISNUMBER(FIND(""time off"",lower(RC[-1]))),""Vacation""" _
    & ",ISNUMBER(FIND(""time-off"",lower(RC[-1]))),""Vacation"",ISNUMBER(FIND(""deactivate"",lower(RC[-1]))),""Deactivated"",ISNUMBER(FIND(""closed for the holiday"",lower(RC[-1]))),""Office(s) Closed"",ISNUMBER(FIND(""working off-site"",lower(RC[-1]))),""Off-site"",ISNUMBER(FIND(""working off site"",lower(RC[-1]))),""Off-site"",ISNUMBER(FIND(""business trip"",lower(RC[-1]))),""Out of the Office"")"
    
Selection.AutoFill Destination:=Range(ActiveCell, Cells(RowCount, ActiveCell.Column))

Range("L1", Cells(RowCount, ActiveCell.Column)).Select

Selection.Copy

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

'Creating Phone Number Extract Column--------------
Range("G1").Select

ActiveCell.Value = "Phone Number 1"
ActiveCell.Offset(0, 1).Value = "Phone Number 2"
ActiveCell.Offset(0, 2).Value = "Phone Number 3"
ActiveCell.Offset(0, 3).Value = "Phone Number 4"
ActiveCell.Offset(0, 4).Value = "Phone Number 5"
ActiveCell.Offset(0, 5).Value = "Phone Number 6"

Call PhoneExtract
    
'Formatting all cells------------------------------
Range("a1", Cells(RowCount, 12)).Select

With Selection
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlTop
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With

Columns("A:A").Select
Selection.ColumnWidth = 25
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").Select
Selection.ColumnWidth = 25
Columns("E:F").Select
Selection.ColumnWidth = 80
Columns("G:L").Select
Selection.ColumnWidth = 25

Range("A1").Select

ActiveSheet.Range("A1").AutoFilter

Call Mail_workbook_Outlook_1

MsgBox "Macro has completed!"

End Sub
'---------------------------------------------------------------------------------------
'Option Explicit

Sub PhoneExtract()
    Dim str As String, n As Long, rw As Long
    Dim rgx As Object, cmat As Object, ws As Worksheet

    Set rgx = CreateObject("VBScript.RegExp")
    Set ws = Worksheets(ActiveSheet.Name)
    
    Range("G2").Select

    With rgx
        .Global = True
        .MultiLine = True
        'phone number pattern is: ###-###-####
        .Pattern = "[0-9,\-]{12}"
        For rw = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
            str = ws.Cells(rw, "E").Value2
            If .Test(str) Then
                Set cmat = .Execute(str)
                'populate the worksheet with the matches
                For n = 0 To cmat.Count - 1
                    If Left(cmat.Item(n).Value, 2) = "1-" Then
                        ws.Cells(rw, Columns.Count).End(xlToLeft).Offset(0, 1) = ""
                    Else
                        ws.Cells(rw, Columns.Count).End(xlToLeft).Offset(0, 1) = cmat.Item(n)
                    End If
                Next n
            End If
        Next rw
    End With

    Set rgx = Nothing: Set ws = Nothing
    
    Set rgx = CreateObject("VBScript.RegExp")
    Set ws = Worksheets(ActiveSheet.Name)
    
    With rgx
        .Global = True
        .MultiLine = True
        'phone number pattern is: ###-###-####
        .Pattern = "[0-9,\-]{14}"
        For rw = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
            str = ws.Cells(rw, "E").Value2
            If .Test(str) Then
                Set cmat = .Execute(str)
                'populate the worksheet with the matches
                For n = 0 To cmat.Count - 1
                    If Left(cmat.Item(n).Value, 2) = "1-" Then
                        ws.Cells(rw, Columns.Count).End(xlToLeft).Offset(0, 1) = Mid(cmat.Item(n).Value, 3, 500)
                    End If
                Next n
            End If
        Next rw
    End With

    Set rgx = Nothing: Set ws = Nothing
    
    Set rgx = CreateObject("VBScript.RegExp")
    Set ws = Worksheets(ActiveSheet.Name)
    
    With rgx
        .Global = True
        .MultiLine = True
        'phone number pattern is: ###-###-####
        .Pattern = "[0-9,\-]{8}"
        For rw = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
            str = ws.Cells(rw, "E").Value2
            If .Test(str) Then
                Set cmat = .Execute(str)
                'populate the worksheet with the matches
                For n = 0 To cmat.Count - 1
                    If Len(cmat.Item(n).Value) < 9 And Mid(cmat.Item(n).Value, 8, 1) <> "-" Then
                        ws.Cells(rw, Columns.Count).End(xlToLeft).Offset(0, 1) = cmat.Item(n) 'Mid(cmat.Item(n).Value, 3, 500)
                    End If
                Next n
            End If
        Next rw
    End With

    Set rgx = Nothing: Set ws = Nothing

End Sub
'---------------------------------------------------------------------------------------------
Sub Mail_workbook_Outlook_1()
'Working in Excel 2000-2016
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "<co-worker email>"
        .CC = "<co-worker email>"
        .BCC = ""
        .Subject = "Automating Contact Info Updates in Tdf " & Date
        .Body = "This is an automated message that is only sent to specified recipients when an Excel Macro is run for the purpose specified in the subject line."
        .Attachments.Add ActiveWorkbook.FullName
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .Send   'or use .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

我（到目前为止）唯一的问题是电子邮件正文中包含的电话号码的格式都不同。我已经设法解释国家代码和没有国家代码以及 12 位数字（10 位数字和 2 个破折号）与 8 位数字（7 位数字和一个破折号），但我在尝试解释没有任何破折号的 10 位数字时遇到了问题（可能是 8 位不带破折号的数字）。

例如，在电子邮件的正文中，我会有一个像 5853182096 这样的数字，但它只会给我前 8 位数字。

此外，该程序会将其他一些随机数字序列识别为电话号码。例如，有人说“电子通信隐私法，18 U.S.C. Sections 2510-2521”，电话号码输出为 2510-252。有没有办法排除这些。我假设我只需要在最后使用数字通配符进行字符串搜索，并在我看到它们时调整脚本。如果有更简单的方法那就太好了。

不管怎样，让我知道你的想法。与往常一样，我们接受任何和所有帮助，感谢您的支持！

Answer 1

您可以创建更好地匹配您的电话号码变体的正则表达式模式。您的 cmets 仅指示一个模式 (###-###-####) 您的三个正则表达式将返回许多与该模式不匹配的字符串。为了匹配该特定模式，我建议 \b\d{3}-\d{3}-\d{4}\b 但这可能过于严格。您确实需要更仔细地查看可能的模式。鉴于您的代码中的模式，除了您提到的不匹配之外，其中之一还将匹配 1,,456---89147 显然不是电话号码。

我不知道正则表达式是否是您唯一的问题。另外，我不明白（至少对于北美电话号码，您可能的 8 位数模式。我可以理解 7 位数。对于北美电话号码，不考虑国际号码，以下正则表达式将匹配，包括10 位字符串；与 USC 引用不匹配：

\b(?:[2-9]\d{2}-?)?\d{3}-?\d{4}\b 

（北美电话号码不能以[01] 开头）。

其他国家有不同的模式。

这里是正则表达式的解释，以及项目详细信息的链接：

北美风格的电话号码

\b(?:[2-9]\d{2}-?)?\d{3}-?\d{4}\b

选项：区分大小写； ^$ 在换行符处不匹配

• Assert position at a word boundary\b
• Match the regular expression below(?:[2-9]\d{2}-?)?
  • Between zero and one times, as many times as possible, giving back as needed (greedy)?
  • Match a single character in the range between “2” and “9”[2-9]
  • Match a single character that is a “digit”\d{2}
    • Exactly 2 times{2}
  • Match the character “-” literally-?
    • Between zero and one times, as many times as possible, giving back as needed (greedy)?
• Match a single character that is a “digit”\d{3}
  • Exactly 3 times{3}
• Match the character “-” literally-?
  • Between zero and one times, as many times as possible, giving back as needed (greedy)?
• Match a single character that is a “digit”\d{4}
  • Exactly 4 times{4}
• Assert position at a word boundary\b

使用RegexBuddy创建