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

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

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
 
Sub ExtractData()
Dim oItem As MailItem
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
For Each oItem In ActiveExplorer.Selection
CopyToExcel oItem
Next oItem
Set oItem = Nothing
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 = "ALL Data"
Const strWorkBookName As String = "C:\Test1.xls" '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("ALL Data")
 
'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(xlUp).Row + 1
 
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Time Submitted:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vText(i + 6))
End If
 
If InStr(1, vText(i), "Your name") > 0 Then
xlSheet.Range("B" & rCount) = Trim(vText(i + 15))
End If
 
If InStr(1, vText(i), "Customer Email") > 0 Then
'vItem = Split(vText(i), Chr(58))
xlSheet.Range("C" & rCount) = Trim(vText(i + 2))
End If
 
If InStr(1, vText(i), "Customer Phone:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("D" & rCount) = Trim(vItem(1))
End If
 
If InStr(1, vText(i), "Move Date") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("E" & rCount) = Trim(vText(i + 2))
End If
 
If InStr(1, vText(i), "Origin City") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("F" & rCount) = Trim(vText(i + 2))
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
 
 
 
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