Good Afternoon
I am seeking some advice on trying to export text from a mail message to excel. I have found some scripts online which does the jobs when there is an idenfier which proceeds the text I require to export, but in the case where the text is on the line which is below the identifer I cannot seem to find away to copy the text and export it.
I have been able to split the First name and last name and the Product, Order Date, and order name
Here is the body of the message, I would need to take the Delivery Address on the line below the text Delivery Address
The following product(s) has been purchased:
Customer: Pepper Pots - emailaddressatcouk
Qty: 1 STAFF6mA 2013/14 - Six-Month Parking Permit (Staff A) 2013/14
Dispatch Address:
Delivery Address Somewhere, Else, Gloucestershire, GL0 000, United Kingdom
Your item was included as part of the following order:
Order date: 25/06/2014 13:55:54
Order Number: FFFFFFFFFFF
Here is the existing Code that I have
Option Explicit
Sub openExcel()
Dim xlApp As Object
Dim sourceWB As Workbook
Dim sourceWS As Worksheet
Dim strFile As String
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim vItema As Variant
Dim i As Long
Dim oRng As Range
Dim rCount As Long
Dim bXStarted As Boolean
Dim Customer As String
Dim CustomerFirstName As String
Dim CustomerLastName As String
Dim StaffStudentCode As String
Dim DeliveryAddress As String
Dim DeliveryAddressexport As String
Dim Product As String
Dim vehicleregistration As String
Dim makemodelcolour As String
'And so on . . .. .
Set xlApp = CreateObject("Excel.Application")
With xlApp
.Visible = True
.EnableEvents = False
End With
strFile = "C:\Users\securityfch\Test.xlsx"
bXStarted = True
Set sourceWB = Workbooks.Open(strFile, , False, , , , , , , True)
Set sourceWS = sourceWB.Worksheets("Sheet1")
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
rCount = sourceWS.Range("A" & sourceWS.Rows.Count).End(xlUp).Row
rCount = rCount + 1
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Customer: ") > 0 Then
Customer = Replace(vText(i), "Customer: ", "")
'loses the email address
Customer = Left(Customer, InStr(Customer, "-") - 1)
CustomerFirstName = Left(Customer, InStr(Customer, " "))
CustomerLastName = Right(Customer, InStr(Customer, " "))
sourceWS.Range("A" & rCount) = Trim(CustomerFirstName)
sourceWS.Range("B" & rCount) = Trim(CustomerLastName)
End If
If InStr(1, vText(i), "Delivery Address") > 0 Then
DeliveryAddress = Replace(vText(i), "Delivery Address", Chr(10))
DeliveryAddress = Right(DeliveryAddress, InStr(DeliveryAddress, Chr(10)) - 1)
sourceWS.Range("C" & rCount) = Trim(DeliveryAddress)
End If
'If Left(vText(i), 8) = "Question" Then
' If InStr(1, vText(i), "Student or Staff Number") > 0 Then
' rCount = rCount + 1 'so read the next line . . . . .
' StaffStudentCode = Replace(vText(i), "Answer:", " ")
' ElseIf InStr(1, vText(i), "vehicle registration") > 0 Then
' rCount = rCount + 1 'so read the next line . . . . .
' vehicleregistration = Replace(vText(i), "Answer :", " ")
' ElseIf InStr(1, vText(i), "make,model and colour") > 0 Then
' rCount = rCount + 1 'so read the next line . . . . .
' makemodelcolour = Replace(vText(i), "Answer :", " ")
' End If
'End If
If InStr(1, vText(i), "Product :") > 0 Then
vItem = Split(vText(i), Chr(58))
sourceWS.Range("F" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Order date:") > 0 Then
vItem = Split(vText(i), Chr(58))
sourceWS.Range("D" & rCount) = Trim(vItem(1))
End If
If InStr(1, vText(i), "Order Number:") > 0 Then
vItem = Split(vText(i), Chr(58))
sourceWS.Range("E" & rCount) = Trim(vItem(1))
End If
Next i
'Now set all of the fields
'sourceWS.Range("C" & rCount) = Trim(StaffStudentCode)
'sourceWS.Range("D" & rCount) = Trim(DeliveryAddress)
'sourceWS.Range("E" & rCount) = Trim(vehicleregistration)
'sourceWS.Range("F" & rCount) = Trim(makemodelcolour)
'sourceWS.Range("G" & rCount) = Trim(CustomerLastName)
sourceWB.Save
Next olItem
sourceWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set sourceWB = Nothing
Set sourceWS = Nothing
Set olItem = Nothing
End Sub
Any help would be appricated
Thank you