如何find具体的主题，并复制邮件正文中的具体内容

我经历了许多Outlook论坛，无法find正确的代码来满足我的要求。

我有群组邮箱，我们经常收到邮件与主题行
"Request ID 691941: Call Lodged" ，这里是691941随着请求进入邮箱，并保持不变。

我想要的是

1. 我的macros应该保持阅读组邮箱，只要它看到一个新的邮件，只有主题行包含“请求ID xxxxxx：呼叫寄存”其余邮件可以忽略

2. 从邮件正文应该只复制这些领域的优秀。

   i）请求ID 691941（在这里只有691941应该被复制到Excel）

   ii）严重性级别：Sev2（在这个只有Sev2应该被复制到Excel）

   iii）产品：FINCORE（在此只有FINCORE应复制到Excel）

   iv）客户：FINATS（在此只有FINATS应复制到Excel）

   v）date和时间：当这封邮件收到date和时间

在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：呼叫提交
要：[e-mail]
CC：[e-mail]

亲爱的Finacle服务团队，

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

这里第一行是主题行，第二行和第三行是To和CC，剩余是邮件正文

在邮件正文中692248号码不断变化，之后的所有数值将会保持变化，所以之后有什么：应该被捕获

Answer 1

如果你想访问并观看共享的收件箱，然后使用GetSharedDefaultFolder方法和Items.ItemAdd事件（Outlook）

_{GetSharedDefaultFolder方法返回一个MAPIFolder对象，该对象表示指定用户的指定默认文件夹。 在委派scheme中使用此方法，其中一个用户已委派其他用户访问一个或多个默认文件夹。}

---

代码示例

 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("[e-mail]") Set Inbox = olNs.GetSharedDefaultFolder(ShrdRecip, olFolderInbox) Set Items = Inbox.Items End Sub 

_{Items.ItemAdd事件（Outlook）将一个或多个项目添加到指定的集合时发生。 一次将大量项目添加到文件夹时，此事件不会运行。}

---

在这里，我使用ItemAdd事件与正则expression式来捕获主题行

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子

另请参阅按值 ByVal Item As Object 传递参数

_{在Visual Basic中，可以通过值或引用将parameter passing给过程。 这就是所谓的传递机制，它决定了程序是否可以修改调用代码中参数底层的编程元素。 过程声明通过指定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

---

编辑见下面的评论

---

 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