RE: Extract body from email

Hi

I have created a code (borrowing from various sources) in VB to extract certain information from an email and write it to excel. The information is in the format below but there is a table with the information on the right. It works when the table is stripped but won't work when the table is in the email (and that's how the email comes). If anyone could help that would be great.

Contact Information
Prefix:
First Name:
Last Name:
Designation:
Email Address:
CC Email Address:
Company:
Title:
Work Address:
Work Phone:
Work Fax:
Mobile Phone:
Industry:
Department:

This is the code I am using

Option Explicit

Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
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 = "D:\My Documents\Vehicles.xlsx" 'the path of the workbook

If Application.ActiveExplorer.Selection.Count = 0 Then
    MsgBox "No Items selected!", vbCritical, "Error"
    Exit Sub
End If
On Error Resume Next
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)
Set xlSheet = xlWB.Sheets("Sheet1")

'Process each selected record
 rCount = xlSheet.UsedRange.Rows.Count
  For Each olItem In Application.ActiveExplorer.Selection
    sText = olItem.Body
    vText = Split(sText, Chr(13))
    'Find the next empty line of the worksheet
     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), "Source:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("A" & rCount) = Trim(vItem(1))
        End If

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

        If InStr(1, vText(i), "Time:") > 0 Then
            vItem = Split(vText(i), Chr(58))
            xlSheet.Range("Q" & rCount) = Trim(vItem(1))
        End If
    Next i
    xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
    xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub

Thank you for your help

Can you add code tags when posting code?

Code Tags Added
Your post does not comply with Rule 3 of our Forum RULES. Use code tags around code.

Posting code between [CODE] [/CODE] tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

Highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found at http://www.excelforum.com/forum-rule...rum-rules.html



(Because you are new to the forum, I have added them for you today. Please take a few minutes to read all Forum Rules and comply in the future.)