Exporting Outlook Email information to Excel Workbook

Question

I receive an automated email message (in Outlook) every time a room is reserved in a scheduling system but then have to go over and mirror that reservation in another system (which necessitates checking each reservation for specific information and searching through the inbox). I am trying to determine if there is a way to pull the information from the message section (I have found some code that pulls the date received, and subject line as well as read status, but cannot determine how to pull the message body information that I need)

The code that I am running is courtesy of Jie Jenn:

Sub ListOutlookEmailInfoinExcel()
Dim olNS As Outlook.NameSpace
Dim olTaskFolder As Outlook.MAPIFolder
Dim olTask As Outlook.TaskItem
Dim olItems As Outlook.Items

Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim x As Long
Dim arrHeaders As Variant

Set olNS = GetNamespace("MAPI")
Set olTaskFolder = olNS.GetDefaultFolder(olFolderInbox)
Set olItems = olTaskFolder.Items

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add

On Error Resume Next
x = 2
arrHeaders = Array("Date Created", "Date Recieved", "Subject", "Unread?")

xlWB.Worksheets(1).Range("A1").Resize(1, UBound(arrHeaders)).Value = ""

Do

With xlWB.Worksheets(1)
If Not (olItems(x).Subjects = "" And olItems(x).CreationTime = "") Then

.Range("A1").Resize(1, UBound(arrHeaders) + 1) = arrHeaders
.Cells(x, 1).Value = olItems(x).CreationTime
.Cells(x, 2).Value = olItems(x).ReceivedTime
.Cells(x, 3).Value = olItems(x).Subject
.Cells(x, 4).Value = olItems(x).UnRead

x = x + 1
End If
End With


Loop Until x >= olItems.Count + 1

Set olNS = Nothing
Set olTaskFolder = Nothing
Set olItems = Nothing

Set xlApp = Nothing
Set xlWB = Nothing

End Sub

With the above code, I get a readout of the Subject line, the date created/received and whether or not it has been read. I am trying to see if I can, in addition, get some of the unique string data within the message itself. The format of the emails that I receive is as follows:

Message-ID: sample info

User: test

Content1: test

Content2: test

Content3: test

Please submit a service request if you are receiving this message in error.

-Notice of NEW Room Request

Sponsored By: My_example@Test.com

Event Type: Meeting

Event Title: Test

Date of Reservation: 2015-12-02

Room: 150

From: 13:00 To: 14:00

The information will vary with each request, but I was wondering if anyone had any idea on how to capture the unique strings that will come through so that I can keep a log of the requests that is much faster than the current manual entry and double-checks?

Answer 1

As requested in follow up, the following code splits the message body into individual lines of information. A couple of notes: I copied your message exactly from your post, then searched for "Notice of NEW Room Request". Needless to say, this string should always start the block of information that you need. If it varies, then we have to account for the type of messages that may come through. Also, you may have to test how your message body breaks up individual lines. When I copied and pasted your message into Excel, each line break was 2 line feeds (Chr(10) in VBA). In some cases, it may be only one line feed. Or it can be a Carriage Return (Chr(13)), or even both.

Without further ado, see the code below and let us know of questions.

Sub SplitBody()
    Dim sBody As String
    Dim sBodyLines() As String

    sBody = Range("A1").Value

    sBodyLines() = Split(Mid(sBody, InStr(sBody, "Notice of NEW Room Request"), Len(sBody)), Chr(10) & Chr(10))

    For i = LBound(sBodyLines) To UBound(sBodyLines)
        MsgBox (sBodyLines(i))
    Next i
End Sub

Answer 2

Below is an example connecting to an Outlook session, navigating to the default Inbox, then looping through items and adding unread emails to the spreadsheet. See if you can modify the code to your needs, and post back if specific help is needed.

Sub LinkToOutlook()
    Dim olApp As Object
    Dim olNS As Object
    Dim olFolderInbox As Object
    Dim rOutput As Range

    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.getNamespace("MAPI")
    Set olFolderInbox = olNS.GetDefaultFolder(6) 'Gets the default inbox folder

    Set rOutput = Sheet1.Range("A1")

    For Each itm In olFolderInbox.items
        If itm.unread = True Then 'check if it has already been read
            rOutput.Value = itm.body
            Set rOutput = rOutput.Offset(1)
        End If
    Next itm

End Sub

Alternatively, you can write code in Outlook directly that looks for new mail arrival, and from there, you can test if it meets your criteria, and if it does, it can write to Excel. Here's a link to get you started. Post back for added help.

Using VBA to read new Outlook Email?