How to find specific Subject and copy the specific content in the mail body

Question

I have gone through many Outlook forums and could not able to figure out correct code for my requirement.

I have group mail box in we receive mails frequently with Subject line
"Request ID 691941: Call Lodged" , here 691941 keep changing with request coming in mail box and remaining will be same.

What I'm trying to is is;

My Macro should keep reading the group mail box when ever it sees a new mail with only subject line contains "Request ID xxxxxx: Call Lodged " remaining mails can be ignored
from mail body it should copy only these fields to excel.
i) Request ID 691941 (in this only 691941 should be copied to Excel)
ii) Severity Level: Sev2 (in this only Sev2 should be copied to Excel)
iii) Product: FINCORE (in this only FINCORE should be copied to Excel)
iv) Customer:FINATS (in this only FINATS should be copied to Excel)
v) Date & Time : When this mail was received date and time

To copied in Excel in specified columns.

I have below code but its giving error at line No. 12 and line No. 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

Any help is appreciated

Email body look like below

Request ID 692248: Call Lodged
To:xyzlksdksdk@skdmsd.com
cc:xyzlksdksdk@skdmsd.com

Dear Finacle Service Team,

Request ID 692248 is Lodged.
Requester: sjdhjksdj
Severity Level: Sev3-Some Impact
Request Status: With Assignee
Problem Description : Dear xyz, sdlksdjksdlksjdlksd lkjdfklsdjfksdjf klkldsfksdfklsdfkldfkl
Product: FINCORE
Customer: sjdskdjaskldasd

Here first line is the subject line , 2nd & 3rd lines are the To and CC, Remaining is the mail body

in mail body 692248 number keeps changing and all values after : will keep changing so what ever is there after : should be captured

Answer 1

If you wanna access and watch shared Inbox then work with GetSharedDefaultFolder Method and Items.ItemAdd Event (Outlook)

_{GetSharedDefaultFolder Method Returns a MAPIFolder object that represents the specified default folder for the specified user .} _{This method is used in a delegation scenario, where one user has delegated access to another user for one or more of their default folders.}

Code Example

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) Occurs when one or more items are added to the specified collection.} _{This event does not run when a large number of items are added to the folder at once.}

Here I'm using ItemAdd Event with Regex to capture subject line

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

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

ID matches the characters ID literally (case sensitive)
\\s matches any whitespace character (equal to [\\r\\n\\t\\f\\v ] )
1st Capturing Group (\\d{6})
\\d{6} matches a digit (equal to [0-9] )
{6} Quantifier — Matches exactly 6 times

Code Example

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

Once the Email is identified by subject ID & 6 digit numbers then we call the Excel sub

Also see Passing Arguments by Value ByVal Item As Object

_{In Visual Basic, you can pass an argument to a procedure by value or by reference.} _{This is known as the passing mechanism, and it determines whether the procedure can modify the programming element underlying the argument in the calling code.} _{The procedure declaration determines the passing mechanism for each parameter by specifying the ByVal or ByRef keyword.}

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

This what you will get and it will be saved as 692248.xlsx

Edit see below comments

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

How to find specific Subject and copy the specific content in the mail body

Question

1 answers

solution1
0 2017-04-29 00:41:36

How to find specific Subject and copy the specific content in the mail body

Question

1 answers

solution1 0 2017-04-29 00:41:36

solution1
0 2017-04-29 00:41:36