Extract Email Content

[_Richard__]

Hello
Please can you help me?
We are receiving emails form 3rd party companies which contain information regarding our clients. The information we receive is in the following format:

Title: Mr


First Name: Gary


Middle Name: Barry


Surname: Jones


I have written the code below (with assistance from other sources) that I hope to extract from an email, copy to a spreadsheet and save in a specific location but I just cant get the code to recognize the email body and where the columns are located.

the error is either with (i think)

    vText = Split(sText, Chr(13))

or

    For i = UBound(vText) To 0 Step -1

I know that Chr(13) is a carriage return but when the script is run, upon debugging the vText = Split(sText, Chr(13)) will not pick up anything and as a result the Ubound doesnt work and so on. I have used Ubound very little and don't fully understand how it works.

Here is the complete code. Please could you have a look

Option Explicit
Sub VVCopyToExcel(olitem As Outlook.MailItem)


'Dim olitem As Outlook.MailItem


Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "G:\Leads Email\TEST.xlsx"


    On Error Resume Next
    Set olitem = ActiveExplorer.Selection
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Application.StatusBar = "Please wait while Excel source is opened ... "
        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(strPath)
    xlApp.Visible = True
    Set xlSheet = xlWB.Sheets("sheet1")


If (InStr(1, olitem.Body, "Residential Status: OwnerOccupier", vbTextCompare) > 0) Then


Debug.Print olitem.Body


    'Process the message record
    For Each olitem In Application.ActiveExplorer.Selection
    sText = olitem.Body
    vText = Split(sText, Chr(13))
    
    'Find the next empty line of the worksheet
    rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
    rCount = rCount + 1






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


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


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


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


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


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




              
        
    Next i
    xlWB.Save
    Next olitem
    If bXStarted Then
        xlApp.Quit
    End If


End If


    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub

Thank you

 

[_Richard__]

Can anyone help me on this please?
Thanks

 

[Comfy]

Try this on one of your emails:

Sub VVCopyToExcel(olitem As Outlook.MailItem)




'Dim olitem As Outlook.MailItem




Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Dim oMatches, oMatch, oRe
Const strPath As String = "G:\Leads Email\TEST.xlsx"




    On Error Resume Next
    Set olitem = ActiveExplorer.Selection
    Set xlApp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Application.StatusBar = "Please wait while Excel source is opened ... "
        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(strPath)
    xlApp.Visible = True
    Set xlSheet = xlWB.Sheets("sheet1")




If (InStr(1, olitem.Body, "Residential Status: OwnerOccupier", vbTextCompare) > 0) Then




Debug.Print olitem.Body




    'Process the message record
    For Each olitem In Application.ActiveExplorer.Selection
    sText = olitem.Body
    'vText = Split(sText, Chr(13))
    
    'Find the next empty line of the worksheet
    rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
    rCount = rCount + 1


    Set oRe = CreateObject("VBScript.RegExp")


    oRe.Pattern = "(?:.|\n)*(Title: )(\w+)(?:.|\n)*(First Name: )(\w+)(?:.|\n)*(Middle Name: )(\w+)(?:.|\n)*(Surname: )(\w+)(?:.|\n)*"
    Set oMatches = oRe.Execute(sText)
    Set oMatch = oMatches(0)
    
    For i = 1 To 7 Step 2
    Debug.Print oMatch.Submatches(i)
    Next i










    xlWB.Save
    Next olitem
    If bXStarted Then
        xlApp.Quit
    End If




End If




    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
End Sub

Make sure you save everything first.