Parsing Outlook Emails and Exporting to Excel

Question

I'm currently writing a VBA script in Outlook which should parse key information from emails and store them into an Excel spreadsheet.

Right now, I am stuck on the logic of parsing and extracting what I want.

Here is a short example of an email with the info that needs to be extracted and saved into Excel circled in yellow (Xs being capital or lowercase letters and # being numbers)

Here is the Excel layout and what is happening with my current code, nothing is popping up except the headers!

Here is my current code:

Sub Extract()

 On Error Resume Next
    Dim messageArray(3) As String
    Set myOlApp = Outlook.Application
    Dim OlMail As Variant
    Set mynamespace = myOlApp.GetNamespace("mapi")
 
    'Open the current folder, I want to be able to name a specific folder if possible…
 
    Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
    Set xlobj = CreateObject("excel.application.14")
    xlobj.Visible = True
    xlobj.Workbooks.Add
 
    'Set headings
    xlobj.Range("a" & 1).Value = "Priority"
    xlobj.Range("b" & 1).Value = "Summary"
    xlobj.Range("c" & 1).Value = "Description of Trouble"
    xlobj.Range("d" & 1).Value = "Device"
    'xlobj.Range("e" & 1).Value = "Sender"
 
   
    For i = 1 To myfolder.Items.Count
    Set myitem = myfolder.Items(i)
    msgtext = myitem.Body
 
    'Search for specific text
    delimtedMessage = Replace(msgtext, "Priority:", "###")
    delimtedMessage = Replace(delimtedMessage, "Summary:", "###")
    delimtedMessage = Replace(delimtedMessage, "Description of Trouble:", "###")
    delimtedMessage = Replace(delimtedMessage, "Device:", "###")
    messageArray(i) = Split(delimtedMessage, "###")
 
    'Write to Excel
    xlobj.Range("a" & i + 1).Value = messageArray(0)
    xlobj.Range("b" & i + 1).Value = messageArray(1)
    xlobj.Range("c" & i + 1).Value = messageArray(2)
    xlobj.Range("d" & i + 1).Value = messageArray(3)
    'xlobj.Range("e" & i + 1).Value = myitem.To
 
 Next
 
End Sub

Answer 1

here is some code that may get you started

the email message is split into lines

then each line is split at the colon character ... ":"

(the colon is added to end of every line before doing the split, so that blank lines do not produce an error)

then actions are taken, depending on the first few characters of each line

---

put the code at the end of this post into an excel workbook

make sure that outlook is open when you run it

it is not a good idea to enable vba (macros) in outlook because of security issues that may be present inside the received emails

---

some pointers that you may already know:

you can single-step through the code by placing the cursor anywhere within the code and pressing F8 repeatably

the yellow highlight indicates which instruction will execute next

hovering mouse pointer over a variable name will indicate the value of that variable (when stopped at any breakpoint)

clicking inside the left side grey bar next to an instruction will set a breakpoint (not all instructions are 'breakpoint-able')(click again to clear)

pressing F5 will run the program up to the next breakpoint or to end of program if there is no breakpoint

use "watch window" to closely examine objects (variables)

to bring up watch window go to "menu bar" ... "view" ... "watch window"

drag any object name or variable name into the watch window, or right click on it and choose"add watch"

then you can monitor the variable value while stopped at a breakpoint

eg. drag "topOlFolder" from the third Dim statement (or from anywhere else in program)

make use of "immediate window"

press ctrl-G to bring up the "immediate window" ... any "Debug.print" command will print to the "immediate window" ... this is used for displaying any debugging info that you need without having to stop at a breakpoint

---

a good starting point when writing vba code, is to "record macro", then go into vbe ide and edit the resulting macro code to fit your needs

lot of the code in a recorded macro is unnecessary and can be shortenned

for instance, you may be on worksheet "Sheet5" and you need to delete everything from "Sheet2" and continue working on "Sheet5":

you would record a macro for following actions:

"click Sheet2 tab ... select all cells(ctrl-a) ... press delete ... click Sheet5 tab"

produces the following macro

Sub Macro1()
    Sheets("Sheet2").Select
    Cells.Select
    Selection.ClearContents
    Sheets("Sheet5").Select
End Sub

it can be rewritten as:

Sub Macro1()
    Sheets("Sheet2").Cells.ClearContents
End Sub

this clears worksheet named "Sheet2" without "selecting" it, therefore it never flashes briefly on the screen

it can be annoying if some code does a lot of updates to different worksheets and each update flashes up on the screen for a brief moment

---

here is your code

Sub Extract()

'   On Error Resume Next                ' do not use .... masks errors

    Dim myOlApp As Outlook.Application
    Dim myNameSpace As Outlook.Namespace
    Dim topOlFolder As Outlook.MAPIFolder
    Dim myOlFolder As Outlook.Folder
    Dim myOlMailItem As Outlook.mailItem

    Set myOlApp = Outlook.Application                                     ' roll these two into one command line
    Set myNameSpace = myOlApp.GetNamespace("MAPI")                        ' as noted on next line

'   Set myNameSpace = Outlook.Application.GetNamespace("mapi")            ' can do this instead (then no need to do "dim myOlApp" above)

    Set topOlFolder = myNameSpace.GetDefaultFolder(olFolderInbox).Parent  ' top folder ... contains all other folders


'   Set myOlFolder = myNameSpace.Folders(2).Folders("Test")               ' this one is unreliable ... Folders(2) seems to change
    Set myOlFolder = topOlFolder.Folders("Test")                          ' this one seems to always work

'   Set myOlFolder = topOlFolder.Folders(myNameSpace.PickFolder.Name)     ' pick folder name in a dialog

'   Debug.Print myOlFolder.Items.Count

'   For Each myOlMailItem In myOlFolder.Items                             ' print subject lines for all emails in "Test" folder
'       Debug.Print myOlMailItem.Subject
'   Next

    Dim xlObj As Worksheet
    Set xlObj = Sheets("Sheet1")                     ' refer to a specific worksheet
'   Set xlObj = ActiveSheet                          ' whichever worksheet is being worked on

    Dim anchor As Range
    Set anchor = xlObj.Range("b2")                   ' this is where the resulting table is placed ... can be anywhere
'   Set anchor = Sheets("Sheet1").Range("b2")        ' "xlObj" object does not have to be created if you use this form

    ' Set headings
    '      Offset(row,col)
    anchor.Offset(0, 0).Value = "Priority"          ' technically the line should be "anchor.Value = ...", but it lines up this way
    anchor.Offset(0, 1).Value = "Summary"           ' used "offset". that way all the cells are relative to "anchor"
    anchor.Offset(0, 2).Value = "Description of Trouble"
    anchor.Offset(0, 3).Value = "Device"
    anchor.Offset(0, 4).Value = "Sender"


    Dim msgText As String
    Dim msgLine() As String
    Dim messageArray() As String

    i = 0                                            ' adjust excel starting row here, if desired
    For Each myOlMailItem In myOlFolder.Items
        i = i + 1                                    ' first parsed message ends up on worksheet one row below headings

'       msgText = testText                           ' use test message that is defined above
        msgText = myOlMailItem.Body                  ' or use actual email body

        messageArray = Split(msgText, vbCrLf)        ' split into lines

        For j = 0 To UBound(messageArray)
'           Debug.Print messageArray(j)

            msgLine = Split(messageArray(j) & ":", ":")  ' split up line ( add ':' so that blank lines do not error out)

            Select Case Left(msgLine(0), 6)              ' check only first six characters

                Case "Priori"
                    anchor.Offset(i, 0).Value = msgLine(1)             ' text after "Priority:"

                Case "Summar"
                    anchor.Offset(i, 1).Value = messageArray(j + 1)    ' text on next line

                Case "Descri"
                    anchor.Offset(i, 2).Value = messageArray(j + 1)    ' text on next line

                Case "Device"
                    anchor.Offset(i, 3).Value = msgLine(1)             ' text after "Device:"

            End Select
            anchor.Offset(i, 4).Value = myOlMailItem.SenderName
            anchor.Offset(i, -1).Value = i                             ' add row number on left of "Priority" column (make sure that "anchor" is not in first worksheet column)

        Next
    Next
End Sub

Answer 2

Untested:

Sub Extract()

    'On Error Resume Next '<< don't use this!
    Dim messageArray '<< use a variant here
    Set myOlApp = Outlook.Application
    Dim OlMail As Variant
    Set mynamespace = myOlApp.GetNamespace("mapi")

    'Open the current folder, I want to be able to name a specific folder if possible…

    Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
    Set xlobj = CreateObject("excel.application.14")
    xlobj.Visible = True
    xlobj.Workbooks.Add

    'Set headings
    xlobj.Range("a" & 1).Value = "Priority"
    xlobj.Range("b" & 1).Value = "Summary"
    xlobj.Range("c" & 1).Value = "Description of Trouble"
    xlobj.Range("d" & 1).Value = "Device"
    'xlobj.Range("e" & 1).Value = "Sender"


    For i = 1 To myfolder.Items.Count
    Set myitem = myfolder.Items(i)
    msgtext = myitem.Body

    'Search for specific text
    delimtedMessage = Replace(msgtext, "Priority:", "###")
    delimtedMessage = Replace(delimtedMessage, "Summary:", "###")
    delimtedMessage = Replace(delimtedMessage, "Description of Trouble:", "###")
    delimtedMessage = Replace(delimtedMessage, "Device:", "###")
    messageArray = Split(delimtedMessage, "###")'<<edit

    'Write to Excel
    If ubound(messageArray) = 3 then
        xlobj.Range("a" & i + 1).Value = Trim(messageArray(0))
        xlobj.Range("b" & i + 1).Value = Trim(messageArray(1))
        xlobj.Range("c" & i + 1).Value = Trim(messageArray(2))
        xlobj.Range("d" & i + 1).Value = Trim(messageArray(3))
        'xlobj.Range("e" & i + 1).Value = myitem.To
    Else
        Msgbox "Message format? - " & myitem.Subject 
    End If

 Next

End Sub