Find specific Subject line from outlook and copy the content in the mail body to exce

[narsing18]

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 would like to do is;
My Macro should keep reading the group mail box when ever it sees a new mail with only subject line contains "Request ID ******: Call Lodged " remaining mails can be ignored

1. from mail body it should copy only these fields to excel.
   
   i) Request ID ****** (in this only ****** ( Numeric number) should be copied to Excel)
   
   ii) Severity Level: Sev2 (in this only Sev2( this field keep changing like Sev1 or Sev3) should be copied to Excel)
   
   iii) Product: FINCORE (in this only FINCORE(This filed keep changing) should be copied to Excel)
   
   iv) Customer:FINATS (in this only FINATS(This field keep changing) should be copied to Excel)
   
   v) Date & Time : when this mail was received date and time

this should be copied in Excel in specified columns.

[gmayor]

You will need a rule with a script to identify the message subject and process accordingly e.g.

Sub ExtractMessageData(olItem As MailItem)
Const strSubject As String = "Request ID *: Call Lodged"
    On Error Resume Next
    If olItem.Subject Like strSubject Then
        'The subject matches so do something
        MsgBox "True"
    Else
        'The subject doesn't match so do something else
        MsgBox "False"
    End If
lbl_Exit:
    Exit Sub
End Sub

As for extracting the data, this is rather less straightforward, however my web page http://www.gmayor.com/extract_data_from_email.htm explains the different methods depending on how the message format is arranged.

[narsing18]

Hi,

i have tried to execute the code but i am getting

object doesn't support this property or method error at below line

"For Each olItem In Application.ActiveExplorer.Selection"

i have tried below code

Option Explicit

Sub ExtractMessageData()
    Dim olItem As Variant
    'Sub ExtractMessageData(olItem As MailItem)
    Const strSubject As String = "Request ID *: Call Lodged"
    On Error Resume Next
    If olItem.Subject Like strSubject Then
         'The subject matches so do something
        MsgBox "True"
    Else
         'The subject doesn't match so do something else
        MsgBox "False"
    End If
    lbl_Exit:
    Exit Sub
End Sub


Sub TestLines()
    Dim olItem As Variant
    Dim olItem As Outlook.MailItem
    Dim vText() As String
    Dim sText As String
    Dim i As Long
    For Each olItem In Application.ActiveExplorer.Selection
        sText = Replace(olItem.Body, Chr(160), Chr(32))
        vText = Split(sText, Chr(13))
        For i = 0 To UBound(vText)
            sText = "Line " & i & vbCr & vText(i)
            If i < UBound(vText) - 1 Then
                sText = sText & vbCr & _
                "Line " & i + 1 & vbCr & vText(i + 1)
            End If
            If i < UBound(vText) - 2 Then
                sText = sText & vbCr & _
                "Line " & i + 2 & vbCr & vText(i + 2)
            End If
            If MsgBox(sText, vbOKCancel) = vbCancel Then Exit Sub
            Next i
        Next olItem
End Sub


Sub CopyToExcel()
    'Sub CopyToExcel(olItem As MailItem)
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim vText As Variant
    Dim sText As String
    Dim sAddr As String
    Dim vAddr As Variant
    Dim vItem As Variant
    Dim i As Long, j As Long
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim olItem As Variant
    Const strWorkSheetName As String = "Sheet1"
    Const strWorkBookName As String = "D:\outlook_project\WorkBookName.xlsx" 'the path of the workbook
    'Use FileExists function to determine the availability of the workbook
    If Not FileExists(strWorkBookName) Then Exit Sub
    'Get Excel if it is running, or open it if not
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error GoTo 0
    'Open the workbook to input the data
    Set xlWB = xlApp.Workbooks.Open(strWorkBookName)
    Set xlSheet = xlWB.Sheets("Sheet1")
    'Process the message
    With olItem
        sText = olItem.Body
        vText = Split(sText, Chr(13))
        'Find the next empty line of the worksheet
        rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row + 1
        'Check each line of text in the message body
        For i = UBound(vText) To 0 Step -1
            If InStr(1, vText(i), "Requester:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Severity Level:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Problem Description:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("C" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Product:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("D" & rCount) = Trim(vItem(1))
            End If
            If InStr(1, vText(i), "Customer:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("E" & rCount) = Trim(vItem(1))
            End If
            'If InStr(1, vText(i), "Origin City:") > 0 Then
                'vItem = Split(vText(i), Chr(58))
                'xlSheet.Range("F" & rCount) = Trim(vItem(1))
            'End If
            'If InStr(1, vText(i), "Origin State:") > 0 Then
                'vItem = Split(vText(i), Chr(58))
                'xlSheet.Range("G" & rCount) = Trim(vItem(1))
            'End If
            'If InStr(1, vText(i), "Origin Zip:") > 0 Then
                'vItem = Split(vText(i), Chr(58))
                'xlSheet.Range("H" & rCount) = Trim(vItem(1))
            'End If
            'If InStr(1, vText(i), "Destination City:") > 0 Then
                'vItem = Split(vText(i), Chr(58))
                'xlSheet.Range("I" & rCount) = Trim(vItem(1))
            'End If
            'If InStr(1, vText(i), "Destination State:") > 0 Then
                'vItem = Split(vText(i), Chr(58))
                'xlSheet.Range("J" & rCount) = Trim(vItem(1))
            End If
            'If InStr(1, vText(i), "Destination Zip:") > 0 Then
                 'vItem = Split(vText(i), Chr(58))
                 'xlSheet.Range("K" & rCount) = Trim(vItem(1))
            'End If
            'If InStr(1, vText(i), "Vehicle Type:") > 0 Then
                'vItem = Split(vText(i), Chr(58))
                'xlSheet.Range("L" & rCount) = Trim(vItem(1))
            'End If
            'If InStr(1, vText(i), "Vehicle Year:") > 0 Then
                'vItem = Split(vText(i), Chr(58))
                'xlSheet.Range("M" & rCount) = Trim(vItem(1))
            'End If
            'If InStr(1, vText(i), "Vehicle Make:") > 0 Then
                'vItem = Split(vText(i), Chr(58))
                'xlSheet.Range("N" & rCount) = Trim(vItem(1))
            'End If
            'If InStr(1, vText(i), "Vehicle Model:") > 0 Then
                'vItem = Split(vText(i), Chr(58))
                'xlSheet.Range("O" & rCount) = Trim(vItem(1))
            'End If
            'If InStr(1, vText(i), "Vehicle Condition:") > 0 Then
                'vItem = Split(vText(i), Chr(58))
                'xlSheet.Range("P" & rCount) = Trim(vItem(1))
            'End If
            'If InStr(1, vText(i), "Comments:") > 0 Then
                'vItem = Split(vText(i), Chr(58))
                'xlSheet.Range("Q" & rCount) = Trim(vItem(1))
            'End If
        Next i
        xlWB.Save
    End With
    xlWB.Close SaveChanges:=True
    If bXStarted Then
        xlApp.Quit
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub

Public Function FileExists(ByVal Filename As String) As Boolean
    Dim nAttr As Long
    On Error GoTo NoFile
    nAttr = GetAttr(Filename)
    If (nAttr And vbDirectory) <> vbDirectory Then
        FileExists = True
    End If
    NoFile:
End Function

when i tried copying in Thisoutlooksession i didn't get any error and it was showing messages as updated in website with line numbers but it didn't copy any this to excel

[gmayor]

Did you select the items before trying to run the macro? You may find - http://www.gmayor.com/extract_email_data_addin.htm helpful.

As for the rest of your code, it is impossible to test without access to your messages, but the following should be closer. The code goes in a new standard module and ExtractMessageData is intended to be called from another process - usually the rule that processes the messages as they arrive. I have added a macro to test the process. Select a message and run the macro. If the workbook is valid and your extraction selections are valid the worksheet should be populated with the data from the selected item.

Option Explicit

Sub TestProcess()
Dim olMsg As MailItem
    On Error Resume Next
    Set olMsg = ActiveExplorer.Selection.Item(1)
    ExtractMessageData olMsg
lbl_Exit:
    Exit Sub
End Sub

Sub ExtractMessageData(olItem As MailItem)
Const strSubject As String = "Request ID *: Call Lodged"
    On Error Resume Next
    If olItem.Subject Like strSubject Then
        CopyToExcel olItem
    Else
        'The subject doesn't match so do something else
        MsgBox "The message does not match the subject criteria" 'Optional
    End If
lbl_Exit:
    Exit Sub
End Sub

Sub TestLines()
Dim olItem As Outlook.MailItem
Dim vText() As String
Dim sText As String
Dim i As Long
    For Each olItem In Application.ActiveExplorer.Selection
        sText = Replace(olItem.Body, Chr(160), Chr(32))
        vText = Split(sText, Chr(13))
        For i = 0 To UBound(vText)
            sText = "Line " & i & vbCr & vText(i)
            If i < UBound(vText) - 1 Then
                sText = sText & vbCr & _
                        "Line " & i + 1 & vbCr & vText(i + 1)
            End If
            If i < UBound(vText) - 2 Then
                sText = sText & vbCr & _
                        "Line " & i + 2 & vbCr & vText(i + 2)
            End If
            If MsgBox(sText, vbOKCancel) = vbCancel Then Exit Sub
        Next i
    Next olItem
End Sub

Sub CopyToExcel(olItem As MailItem)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText As Variant
Dim sText As String
Dim sAddr As String
Dim vAddr As Variant
Dim vItem As Variant
Dim i As Long, j As Long
Dim rCount As Long
Dim bXStarted As Boolean

Const strWorkSheetName As String = "Sheet1"
Const strWorkBookName As String = "D:\outlook_project\WorkBookName.xlsx"    'the path of the workbook
    'Use FileExists function to determine the availability of the workbook
    If Not FileExists(strWorkBookName) Then
        MsgBox "Workbook '" & strWorkBookName & "' is not available."
        Exit Sub
    End If
    'Get Excel if it is running, or open it if not
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
        bXStarted = True
    End If
    On Error GoTo 0

    'Open the workbook to input the data
    Set xlWB = xlApp.Workbooks.Open(strWorkBookName)
    Set xlSheet = xlWB.Sheets(strWorkSheetName)


    'Process the message
    With olItem
        sText = olItem.Body
        vText = Split(sText, Chr(13))
        'Find the next empty line of the worksheet
        rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row + 1


        'Check each line of text in the message body
        For i = UBound(vText) To 0 Step -1
            If InStr(1, vText(i), "Requester:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("A" & rCount) = Trim(vItem(1))
            End If


            If InStr(1, vText(i), "Severity Level:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("B" & rCount) = Trim(vItem(1))
            End If


            If InStr(1, vText(i), "Problem Description:") > 0 Then
                vItem = Split(vText(i), Chr(58))
                xlSheet.Range("C" & rCount) = Trim(vItem(1))
            End If


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


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

        Next i
        xlWB.Save
    End With
    xlWB.Close SaveChanges:=True
    If bXStarted Then
        xlApp.Quit
    End If
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub


Private Function FileExists(ByVal Filename As String) As Boolean
Dim nAttr As Long
    On Error GoTo NoFile
    nAttr = GetAttr(Filename)
    If (nAttr And vbDirectory) <> vbDirectory Then
        FileExists = True
    End If
NoFile:
End Function

[narsing18]

Hi Graham,

i tried your add-in copying it in startup its showing copying and went upto 11% and stopped there when i checked if data was copying ..the excel was empty.
and i didnt understand what do you mean by Did you select the items before trying to run the macro? do i need to select before running the code.

I am new to VBA coding.

[gmayor]

Using the macros TestProcess you need to have one message selected. Using the macro TestLines you need to have one or more messages selected.
The web page explains how to use the add-in. It sounds as though you have tried to process an incompatible message, but without access to the messages it is impossible to debug this.
Outlook VBA is not the best place for people new to VBA to jump in at the deep end.