Parse Outlook message body to Excel File

Hi I have an email that comes into my inbox every couple of minutes.  I want to strip the message body text and put it in ROW format in an Excel/CVS file.  The tricky part is that i want to pull in everything to the Right of the =(equal) sign.  The format of the body is below and as you can see it is Horizontal.  I need to get it Vertical and each item in a cell.  Help Please!

HireDate = Fri Mar 28 14:30:50 2014
HireMgr = Me
HireRpt = You
Pager_Number = 123-11-1234
comment=Both_Qualify
id_counter=1
employee1_firstname=me
employee1_middlename=me
employee1_lastname=m3
employee1_ssn=---------
employee1_ssn_counter=1
employee1_dob=12/06/1900
employee1_addr=123 main street
employee1_addr_counter=10
employee1_apt=2
employee1_city=miami
employee1_state=fl
employee1_zip=33150
employee1_idtype=dl
employee1_idnum=6
employee1_idnum_counter=1
employee1_email=something@122
employee1_email_counter=1
employee1_priphone=123-123-1234
employee1_phone_counter=3
employee1_action=NA
employee2_firstname=you
employee2_middlename=y
employee2_lastname=your
employee2_ssn=---------
employee2_dob=09/24/1900
employee2_addr=123 main street
employee2_apt=NA
employee2_city=miami
employee2_state=fl
employee2_zip=33150
employee2_idtype=dl
employee2_idnum=123
employee2_email=pb@pb
employee2_priphone=123-12-1234
employee2_action=NA
Work_City=Fort Lauderdale
Work_Region=FL
Work_Country=United States
Work_Country_code=US
farmingtonisAsked:
Who is Participating?

Improve company productivity with a Business Account.Sign Up

x
 
mvidasConnect With a Mentor Commented:
Similar to my first one, this will add an attachment to the sheet you run it on with the lines split into one row:
Sub farmingtonisSplit()
    Dim vText As String, olItem As Outlook.MailItem, vLines As Variant
    Set olItem = ActiveExplorer.Selection.Item(1)
    vText = olItem.Body
    vLines = Split(vText, vbCrLf)
    For i = LBound(vLines) To UBound(vLines)
     If vLines(i) Like "*=*" Then
      vText = Mid(vLines(i), InStr(1, vLines(i), "=") + 1)
      vLines(i) = Trim(vText)
     End If
    Next
   
    Dim xlApp As Object, xlBook As Object, xlSheet As Object
    Set xlApp = CreateObject("excel.application")
    Set xlBook = xlApp.Workbooks.Add(1)
    xlBook.ActiveSheet.Range("A1").Resize(1, UBound(vLines) + LBound(vLines) - 1).Value = vLines
    vText = Environ("temp") & "\" & CStr(CLng(Rnd() * 89999999) + 10000000) & ".xlsx"
    xlBook.SaveAs vText
    xlBook.Close False
    xlApp.Quit
    Set xlApp = Nothing
    olItem.Attachments.Add vText
    olItem.Save
    Kill vText
End Sub

Open in new window

0
 
nutschCommented:
HTML or Plain Text body?
0
 
mvidasCommented:
This will add the values as a csv string at the top of the email you run it on:
Sub farmingtonisSplit()
    Dim vText As String, olItem As Outlook.MailItem, vLines As Variant
    Set olItem = ActiveExplorer.Selection.Item(1)
    vText = olItem.Body
    vLines = Split(vText, vbCrLf)
    For i = LBound(vLines) To UBound(vLines)
     If vLines(i) Like "*=*" Then
      vText = Mid(vLines(i), InStr(1, vLines(i), "=") + 1)
      vLines(i) = Trim(vText)
     End If
    Next
    olItem.Body = Join(vLines, ",") & vbCrLf & vbCrLf & olItem.Body
End Sub

Open in new window

We can adapt it to send it to excel pretty easily, but you'll have to explain where you want it, etc.

Matt
0
Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
nutschCommented:
This code might work for you if you run it after selecting the email. It will put the values in columns in a new excel worksheet.

Sub ProcessReceivedInvoice()
Dim xlApp As Excel.Application, sBody As String, xlWbk As Excel.Workbook
Dim mySelectedItem As MailItem, arrBody, lLoop As Long

Set mySelectedItem = miFnGetSelectedItem

sBody = mySelectedItem.Body

Set xlApp = xlappFnGetExcel
Set xlWbk = xlApp.Workbooks.Add

arrBody = Split(sBody, vbCrLf)

xlApp.ScreenUpdating = False

For lLoop = LBound(arrBody) To UBound(arrBody)
    xlWbk.Sheets(1).Cells(1, lLoop + 1).value = Mid(arrBody(lLoop), InStr(arrBody(lLoop), "=") + 1)

Next

xlApp.ScreenUpdating = True

End Sub

Function miFnGetSelectedItem() As MailItem

    Dim MyOlApplication As Outlook.Application
    Dim MyOlNameSpace As NameSpace
    Dim myOlSelection
    
     Set MyOlApplication = CreateObject("Outlook.Application")
     Set MyOlNameSpace = MyOlApplication.GetNamespace("MAPI")
     Set myOlSelection = MyOlApplication.ActiveExplorer.Selection
     
     If myOlSelection.Count = 0 Then
        Msgbox "Please select an item first", vbExclamation
        Exit Function
     End If
     
     If myOlSelection.Count > 1 Then
        Msgbox "Please select only one item", vbExclamation
        Exit Function
     End If
     
     Set miFnGetSelectedItem = myOlSelection.Item(1)
    
    
     'Cleanup
     Set MyOlApplication = Nothing
     Set MyOlNameSpace = Nothing
     Set myOlSelection = Nothing
    

End Function


Public Function xlappFnGetExcel()
Dim xlApp As Excel.Application

On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Not xlApp.Visible Then xlApp.Visible = True
On Error GoTo 0

If xlApp Is Nothing Then
  Set xlApp = CreateObject("Excel.Application")
  xlApp.Visible = True
End If

Set xlappFnGetExcel = xlApp

End Function

Open in new window

0
 
farmingtonisAuthor Commented:
I think my post was a little confusing.  I need the tool to go through every email in a specific email box and then write the contents to an existing .csv file.  I don't need them emailed or attached to an email.  Something like this:

Sub GetInbox()
    Dim olApp, olNamespace, olInbox, olItem
    Dim strFileName As String, objFS, objTS
    Set olApp = CreateObject("Outlook.Application")
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olInbox = olNamespace.GetDefaultFolder(6).Folders("0_Kevin")
 
 
    strFileName = "C:\test1.csv"
    Set objFS = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set objTS = objFS.getfile(strFileName)
    If Err.Number <> 0 Then objFS.CreateTextFile strFileName
    On Error GoTo 0
    Set objTS = objFS.OpenTextFile(strFileName, 8)
 
    On Error Resume Next
    For Each olItem In olInbox.Items
        objTS.Write olItem.SenderName & ", " & olItem.Subject & ", " & olItem.ReceivedTime & ", " & olItem.Body
        objTS.writeline
    Next
 
    objTS.Close
    Set olApp = Nothing
End Sub


As you can see this writes to an excel file, but doesn't put it in the format I need.
0
 
nutschCommented:
Try this update of your code:

Sub GetInbox()
    Dim olApp, olNamespace, olInbox, olItem, arrBody, lLoop As Long, sTemp As String
    Dim strFileName As String, objFS, objTS
    Set olApp = CreateObject("Outlook.Application")
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olInbox = olNamespace.GetDefaultFolder(6).Folders("0_Kevin")
    
    strFileName = "C:\test1.csv"
    Set objFS = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set objTS = objFS.GetFile(strFileName)
    If Err.Number <> 0 Then objFS.CreateTextFile strFileName
    On Error GoTo 0
    Set objTS = objFS.OpenTextFile(strFileName, 8)
 
    On Error Resume Next
    For Each olItem In olInbox.Items
        arrBody = Split(sBody, vbCrLf)
        sTemp = ""
        
        For lLoop = LBound(arrBody) To UBound(arrBody)
            sTemp = sTemp & """" & Mid(arrBody(lLoop), InStr(arrBody(lLoop), "=") + 1) & ""","
        Next
        
        objTS.Write sTemp
        objTS.WriteLine
    Next
 
    objTS.Close
    Set olApp = Nothing
End Sub

Open in new window

0
 
farmingtonisAuthor Commented:
For the last one it isn't actually writing anything to a file.  It doesn't error our, but also doesn't put in anything in the file.
0
 
farmingtonisAuthor Commented:
I think i may have been a little confusing on my question.  I will need to repost with some clarity.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.