Question

我经历了很多Outlook论坛，无法找到符合我要求的正确代码。

我有群组邮箱，我们经常收到主题行 "Request ID 691941: Call Lodged" 的邮件，此处 691941 会随着请求不断更改进入邮箱，剩下的将是一样的。

我想要的是;

My Macro应该在看到新邮件时继续阅读群组邮箱，主题行包含＆＃34;请求ID xxxxxx：Call Lodged＆＃34;剩下的邮件可以忽略
它应该只将这些字段复制到excel。

i）请求ID 691941（此处仅691941应复制到Excel）

ii）严重级别：Sev2（此时只有Sev2应复制到Excel）

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

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

v）日期＆amp;时间：收到此邮件的日期和时间

在指定列中的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

这里的第一行是主题行，第二行和第二行。第3行是To和CC，Remaining是邮件正文

在邮件正文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 一起使用 https://regex101.com/r/5adLgo/3 来捕捉主题专栏

<强> Request ID 691941: Call Lodged
的

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


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

Passing Arguments by Value

代码示例

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中，您可以通过值或引用将参数传递给过程。这称为传递机制，它确定过程是否可以修改调用代码中参数的基础编程元素。过程声明通过指定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

{{3}}

编辑，请参阅以下评论

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

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

1 个答案: