Hi

I have this VBA script working with Excel 2016.
This script exports all emails from a specific Outlook folder from a specified date and copies specific information from the contents of the email body. The emails all are formated the same.

I need help to change it so that I can do the following;

1. I want to include the city and State from the email body with the address line into the same column in my excel file.
2. I want to only inlclude the Foreman's name and not his phone number.
3. If possible I would like to change the code to have it run automaticly everytime a new email is received. (I have an outlook rule that moves the email from the inbox into the folder whenever a new one arrives).

Can someone help to change the below code to get the above 3 items?

I have copied a sample of the email below:


Thanks in advance.


Company Name: ABC Company
GF Name and Number: Jim Smith xxx-xxx-xxxx
Number of Crews Working: 2
Circuits being Worked: 12345

Foreman Name and Number: John Doe xxx-xxx-xxxx
Line Number: 12345
Line Name / Point To Point
Structure: 76 - 123
Location Address: 14935 205th Ave
Big Rapids, MI
Estimated Time: 8 am - 6 pm
Estimated Work Days: Monday - Thursday

Code:

Sub ValidateCrewLocations()

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim strBody As String
Dim strFind As String
Dim strColA, strColB, strColC, strColD, strColE As String
Dim xlSheet As Object
Dim itm As Object
Dim i As Integer
Dim sFilterStart As String
Dim sFilterEnd As String
Dim sExtract As String
Dim aExtract() As String
Dim aExtractItems() As String

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Crew Locations")


i = 1


On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1

Worksheets("Sheet1").Range("A6:E250").ClearContents

For Each OutlookMail In Folder.Items
If OutlookMail.ReceivedTime >= Range("From_Date").Value Then
strBody = OutlookMail.Body
strFind = "Line Name / Point To Point"
strColA = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
strColA = Left(strColA, InStr(strColA, vbLf) - 1)
strFind = "Foreman Name and Number: "
strColB = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
strColB = Left(strColB, InStr(strColB, vbLf) - 1)
strFind = "GF Name and Number: "
strColC = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
strColC = Left(strColC, InStr(strColC, vbLf) - 1)
strFind = "Location Address: "
strColD = Mid(strBody, InStr(1, strBody, strFind, 1) + Len(strFind))
strColD = Left(strColD, InStr(strColD, vbLf) - 1)
strColE = OutlookMail.ReceivedTime
Range("Job_Name").Offset(i, 0).Value = strColA
Range("Foreman").Offset(i, 0).Value = strColB
Range("General_Foreman").Offset(i, 0).Value = strColC
Range("Location_Address").Offset(i, 0).Value = strColD
Range("Email_Received_Time").Offset(i, 0).Value = strColE

i = i + 1
End If
Next OutlookMail

Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

End Sub