如何在邮件正文中查找特定主题并复制特定内容

Question

我浏览了许多 Outlook 论坛，但无法找出符合我要求的正确代码。

我有群组邮箱，我们经常收到主题行
"Request ID 691941: Call Lodged" 的邮件，这里 691941 随着邮箱中的请求不断变化，并且剩下的都是一样的。

我想要的是；

1. 当我的宏看到只有主题行包含“Request ID xxxxxx: Call Lodged”的新邮件时，它应该继续阅读组邮箱，其余邮件可以忽略

2. 从邮件正文中，它应该只将这些字段复制到 excel。

   i) 请求 ID 691941（在此仅应将 691941 复制到 Excel）

   ii) 严重性级别：Sev2（此处仅应将 Sev2 复制到 Excel）

   iii) 产品：FINCORE（在此仅应将 FINCORE 复制到 Excel）

   iv) 客户：FINATS（此处仅应将 FINATS 复制到 Excel）

   v) 日期和时间：收到此邮件的日期和时间

复制到 Excel 的指定列中。

我有以下代码，但在第 12 行和第 46 行给出错误

  Sub Test()
  Dim myFolder As MAPIFolder
  Dim Item As Variant 'MailItem
  Dim xlApp As Object 'Excel.Application
  Dim xlWB As Object 'Excel.Workbook
  Dim xlSheet As Object 'Excel.Worksheet
  Dim xlRow As Long
  Dim Keys
  Dim Lines() As String
  Dim I As Long, J As Long, P As Long
  Dim myNamespace As Namespace
  Set myFolder = Application.GetNamespace("MAPI").Folders("Finacle Global Helpdesk").Folders("Inbox")
  'Set myFolder = myNamespace.Folders("Finacle Global Helpdesk").Folders("Inbox")

   Const strPath As String = "D:\book.xlsx" 'the path of the workbook
   'Define keywords
  Keys = Array("Request ID", "Severity Level:", "Product:", _
    "Customer:")
   'Try access to excel
  On Error Resume Next
  Set xlApp = GetObject(, "Excel.Application")
  If xlApp Is Nothing Then
    Set xlApp = CreateObject("Excel.Application")
    If xlApp Is Nothing Then
      MsgBox "Excel is not accessable"
      Exit Sub
    End If
  End If
  On Error GoTo 0
   'Add a new workbook
  Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("sheet1")

  'Write the header
  With xlSheet
    xlRow = 1
    For I = 0 To UBound(Keys)
      .Cells(xlRow, I + 1) = Keys(I)
    Next
    .Cells(xlRow, UBound(Keys) + 2) = "Subject"
  End With
   'Access the outlook inbox folder
  'Set myFolder = myNamespace.Folders("Finacle Global Helpdesk").Folders("Inbox")

  'Visit all mails
  For Each Item In myFolder.Items
     If myItem.Class = olMail Then
    'Is the subject similar?
    If Item.Subject Like "Request ID : Call Lodged" Then
      'Get all lines from the mailbody
      Lines = Split(Item.Body, vbCrLf)
      'Next line in excel sheet
      xlRow = xlRow + 1
      xlSheet.Cells(xlRow, UBound(Keys) + 2) = Item.Subject
       'Visit all lines
      For I = 0 To UBound(Lines)
        'Search all keywords in each line
        For J = 0 To UBound(Keys)
          P = InStr(1, Lines(I), Keys(J), vbTextCompare)
          If P > 0 Then
            'Store the right part after the keyword
            xlSheet.Cells(xlRow, J + 1) = Trim$(Mid$(Lines(I), P + Len(Keys(J)) + 1))
            Exit For
          End If
        Next
      Next
    End If
    End If
  Next
End Sub

感谢您的帮助

邮件正文如下所示

请求 ID 692248：呼叫已提交
至：xyzlksdksdk@skdmsd.com
cc:xyzlksdksdk@skdmsd.com

尊敬的 Finacle 服务团队，

请求 ID 692248 已提交。
请求者：sjdhjksdj
严重性级别：Sev3-一些影响
请求状态：与受让人
问题描述：亲爱的xyz， sdlksdjksdlksjdlksd lkjdfklsdjfksdjf klkldsfksdfklsdfkldfkl
产品：FINCORE
客户：sjdskdjaskldasd

这里第一行是主题行，第二和第三行是收件人和抄送，剩下的是邮件正文

在邮件正文 692248 中的数字不断变化，并且 : 之后的所有值都会不断变化，因此应该捕获 : 之后的所有值

Answer 1

如果您想访问和观看共享收件箱，请使用 GetSharedDefaultFolder Method 和 Items.ItemAdd Event (Outlook)

_{GetSharedDefaultFolder Method 返回代表指定用户的指定默认文件夹的 MAPIFolder 对象。此方法用于委派方案，其中一个用户已将一个或多个默认文件夹的访问权限委派给另一个用户。}

---

代码示例

Option Explicit
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
    Dim olNs As Outlook.NameSpace
    Dim ShrdRecip As Outlook.Recipient
    Dim Inbox  As Outlook.MAPIFolder

    Set olNs = Application.GetNamespace("MAPI")
    Set ShrdRecip = olNs.CreateRecipient("0m3r@email.com")
    Set Inbox = olNs.GetSharedDefaultFolder(ShrdRecip, olFolderInbox)
    Set Items = Inbox.Items
End Sub

_{Items.ItemAdd Event (Outlook) 在将一个或多个项目添加到指定集合时发生。当大量项目同时添加到文件夹时，此事件不运行。}

---

这里我使用 ItemAdd Event 和 Regex 来捕获主题行

Request ID 691941: Call Lodged
https://regex101.com/r/5adLgo/3

Pattern = "ID\s(\d{6})"

ID 匹配字符 ID 字面意思（区分大小写）
\s 匹配任何空白字符（等于[\r\n\t\f\v ]）
第一个捕获组 (\d{6})
\d{6} 匹配一个数字（等于 [0-9]）
{6} 量词 - 完全匹配6次

代码示例

Private Sub Items_ItemAdd(ByVal Item As Object)
    Dim Matches As Variant
    Dim RegExp As Object
    Dim Pattern As String

    Set RegExp = CreateObject("VbScript.RegExp")

    If TypeOf Item Is Outlook.mailitem Then

        Pattern = "ID\s(\d{6})"
        With RegExp
            .Global = False
            .Pattern = Pattern
            .IgnoreCase = True
             Set Matches = .Execute(Item.subject)
        End With

        If Matches.Count > 0 Then
            Debug.Print Item.subject ' Print on Immediate Window
            Excel Item ' <-- call Sub
        End If

    End If

    Set RegExp = Nothing
    Set Matches = Nothing
End Sub

一旦电子邮件被主题ID & 6 digit numbers 识别，我们就调用 Excel 子

另见Passing Arguments by Value ByVal Item As Object

_{在 Visual Basic 中，您可以通过值或引用将参数传递给过程。这称为传递机制，它确定过程是否可以修改调用代码中参数背后的编程元素。过程声明通过指定 ByVal 或 ByRef 关键字来确定每个参数的传递机制。}

Private Sub Excel(ByVal Item As Object)
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSht As Excel.Worksheet
    Dim xlStarted As Boolean
    Dim Keys() As Variant
    Dim FilePath As String
    Dim SavePath As String
    Dim SaveName As String
    Dim xlCol As Long
                ' ^ Excel variables


    Dim sText As String
    Dim vText As Variant
    Dim vItem As Variant
                ' ^ Item variables

    Dim i As Long

    '// Workbook Path
    FilePath = "C:\Temp\Book1.xlsx"

    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Application.StatusBar = "Please wait while Excel source is opened ... "
        Set xlApp = CreateObject("Excel.Application")
        xlStarted = True
    End If
    On Error GoTo 0

    'Define keywords
    Keys = Array("Request ID", "Severity Level:", "Product:", "Customer:")

    '// Open workbook to input the data
    Set xlBook = xlApp.Workbooks.Open(FilePath)
    Set xlSht = xlBook.Sheets("Sheet1")

    'Write the header
    With xlSht
        xlCol = 1
        For i = 0 To UBound(Keys)
            .Cells(xlCol, i + 1) = Keys(i)
        Next
        .Cells(xlCol, UBound(Keys) + 2) = "Received Time"
    End With

    '// Process Mail body
    '// Get the text of the message
    '// and split it by paragraph
    sText = Item.Body
    vText = Split(sText, Chr(13)) ' Chr(13)) carriage return

    '// Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1

        '// locate the text relating to the item required
        If InStr(1, vText(i), "Request ID") > 0 Then
            vItem = Split(vText(i), Chr(32)) ' 32 = space & 58 = :
            xlSht.Range("A2") = Trim(vItem(2))
        End If

        '// locate the text relating to the item required
        If InStr(1, vText(i), "Severity Level:") > 0 Then
            vItem = Split(vText(i), Chr(58)) ' 58 = :
            xlSht.Range("B2") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Product:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSht.Range("C2") = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Customer:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSht.Range("D2") = Trim(vItem(1))
        End If

        xlSht.Range("E2") = Item.ReceivedTime

    Next i

    '//
    SavePath = "C:\Temp\"
    SaveName = xlBook.Sheets("Sheet1").Range("A2").Text

    xlBook.SaveAs FileName:=SavePath & SaveName

    '// Close & SaveChanges
    xlBook.Close SaveChanges:=True
    If xlStarted Then
        xlApp.Quit
    End If

    Set xlApp = Nothing
    Set xlBook = Nothing

End Sub

这是您将获得的内容，并将保存为 692248.xlsx

---

编辑见下文cmets

---

Private Sub Excel(ByVal Item As Object)
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSht As Excel.Worksheet
    Dim xlStarted As Boolean
    Dim Keys() As Variant
    Dim FilePath As String
'    Dim SavePath As String <--- Remove
'    Dim SaveName As String <--- Remove
    Dim xlCol As Long
                ' ^ Excel variables


    Dim sText As String
    Dim vText As Variant
    Dim vItem As Variant
                ' ^ Item variables

    Dim i As Long
    Dim AddRow As Long '<---added

    '// Workbook Path
    FilePath = "C:\Temp\Book1.xlsx"

    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Application.StatusBar = "Please wait while Excel source is opened ... "
        Set xlApp = CreateObject("Excel.Application")
        xlStarted = True
    End If
    On Error GoTo 0

    'Define keywords
    Keys = Array("Request ID", "Severity Level:", "Product:", "Customer:")

    '// Open workbook to input the data
    Set xlBook = xlApp.Workbooks.Open(FilePath)
    Set xlSht = xlBook.Sheets("Sheet1")

    'Write the header
    With xlSht
        xlCol = 1
        For i = 0 To UBound(Keys)
            .Cells(xlCol, i + 1) = Keys(i)
        Next
        .Cells(xlCol, UBound(Keys) + 2) = "Received Time"
    End With

    '// Process Mail body
    '// Get the text of the message
    '// and split it by paragraph
    sText = Item.Body
    vText = Split(sText, Chr(13)) ' Chr(13)) carriage return

    '// Check each line of text in the message body
    For i = UBound(vText) To 0 Step -1

        '// Find the next empty line of the worksheet
        AddRow = xlSht.Range("A" & xlSht.Rows.Count).End(xlUp).Row '<---added
        AddRow = AddRow + 1 '<---added


        '// locate the text relating to the item required
        If InStr(1, vText(i), "Request ID") > 0 Then
            vItem = Split(vText(i), Chr(32)) ' 32 = space & 58 = :
            xlSht.Range("A" & AddRow) = Trim(vItem(2))
        End If

        '// locate the text relating to the item required
        If InStr(1, vText(i), "Severity Level:") > 0 Then
            vItem = Split(vText(i), Chr(58)) ' 58 = :
            xlSht.Range("B" & AddRow) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Product:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSht.Range("C" & AddRow) = Trim(vItem(1))
        End If

        If InStr(1, vText(i), "Customer:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSht.Range("D" & AddRow) = Trim(vItem(1))
        End If

        xlSht.Range("E" & AddRow) = Item.ReceivedTime

    Next i

''    '//                                                   <--- Remove
''    SavePath = "C:\Temp\"
''    SaveName = xlBook.Sheets("Sheet1").Range("A2").Text   <--- Remove
''
''    xlBook.SaveAs FileName:=SavePath & SaveName           <--- Remove


    With xlSht.Cells
        .Rows.AutoFit
        .Columns.AutoFit
    End With

    '// Close & SaveChanges
    xlBook.Close SaveChanges:=True
    If xlStarted Then
        xlApp.Quit
    End If

    Set xlApp = Nothing
    Set xlBook = Nothing

End Sub