Solved

Parse Outlook message body to Excel File

Posted on 2014-03-28
8
1,105 Views
Last Modified: 2014-04-09
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
0
Comment
Question by:farmingtonis
  • 3
  • 3
  • 2
8 Comments
 
LVL 39

Expert Comment

by:nutsch
ID: 39962013
HTML or Plain Text body?
0
 
LVL 35

Expert Comment

by:mvidas
ID: 39962035
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
 
LVL 39

Expert Comment

by:nutsch
ID: 39962048
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
Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

 
LVL 35

Accepted Solution

by:
mvidas earned 500 total points
ID: 39962055
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
 

Author Comment

by:farmingtonis
ID: 39962230
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
 
LVL 39

Expert Comment

by:nutsch
ID: 39962247
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
 

Author Comment

by:farmingtonis
ID: 39984229
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
 

Author Closing Comment

by:farmingtonis
ID: 39989213
I think i may have been a little confusing on my question.  I will need to repost with some clarity.
0

Featured Post

Microsoft Certification Exam 74-409

Veeam® is happy to provide the Microsoft community with a study guide prepared by MVP and MCT, Orin Thomas. This guide will take you through each of the exam objectives, helping you to prepare for and pass the examination.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Find out what you should include to make the best professional email signature for your organization.
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

770 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question