Extract the content of an e-mail to Word with VBA

There is no charge for using any of the material (for personal use) on this web site, but if you wish to make a contribution to the ever growing running costs, any donation would be much appreciated. Click the adjacent button to access PayPal

Extract the content of an Outlook e-mail message or attachment to a Word document

As my income is primarily in Sterling and I live in a country where the currency is the Euro, it is essential that I keep a weather eye on the exchange rate - which from summer 2007 to summer 2008 has seen Sterling in terminal decline .

To facilitate this I receive a daily e-mailed update from www.xe.com which shows a raft of exchange rates from around the world set to a base currency of your choice - which for me is the Euro. The message shows the currencies, as in the extract below, c/w some variable header and footer text. The messages are automatically diverted to an Inbox sub folder in Outlook called "Euro" using Outlooks rules.

It is possible to read the last message in the Outlook Inbox with a minor modification to these code examples, but if you have a requirement to read only messages of a certain type or from a certain sender, I strongly recommend that you create an Outlook mail folder and divert those messages to it.

Currency Unit EUR per Unit Units per EUR

================================ =================== ===================

USD United States Dollars 0.6339811431 1.5773339806

EUR Euro 1.0000000000 1.0000000000

GBP United Kingdom Pounds 1.2636051862 0.7913864322

CAD Canada Dollars 0.6277140473 1.5930820798

AUD Australia Dollars 0.6084550880 1.6435066774

JPY Japan Yen 0.0059718125 167.4533486363

INR India Rupees 0.0148195686 67.4783476888

NZD New Zealand Dollars 0.4820162698 2.0746187685

CHF Switzerland Francs 0.6223859713 1.6067200196

etc ...............

I am only interested in the GBP entry (highlighted in red), so a number of years ago I began copying the required line and pasted it into a running log. Inevitably thoughts moved to automating the process using macros. My first attempts entailed programming in Outlook's vba to extract the data from the most recent message, to set the message as read, to open a Word document and insert the content of the message, ready for further processing using Word vba to extract the highlighted line and add it to a new row at the end of my Word log table document. Initially the processing was done in Office 2003, but later was transferred to 2007. The macros work for both.

The original Outlook macro is as follows. Thanks go to fellow Word MVP Tony Jollons for helping out with the code.

Sub OpenWord()
'Create this macro in OUTLOOK!

Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem

Dim WordWasNotRunning As Boolean

Set olItems = Application.Session.GetDefaultFolder(olFolderInbox).Folders("Euro").Items
olItems.Sort "[Received]", True
Set olItem = olItems(1)

WordWasNotRunning = False
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
WordWasNotRunning = True
End If
Set wdDoc = wdApp.Documents.Add

wdDoc.Content.InsertAfter olItem.Body

olItem.UnRead = False
Set olItem = Nothing
Set olItems = Nothing

wdApp.WindowState = wdWindowStateMinimize
wdApp.Visible = True
wdApp.WindowState = wdWindowStateNormal

' do whatever else you want here - Application.Run YourMacro etc.
wdApp.Run "ExtractEUR"

' and when you're finished if Word was started by the macro close Word
If WordWasNotRunning = True Then
wdApp.Quit
End If

Set wdDoc = Nothing
Set wdApp = Nothing
End Sub

Then in June 2008 a user in a Word forum, with a similar requirement, reported that he was working in a corporate environment and was unable to add macros to Outlook, so asked if he could work entirely from Word to achieve the same ends? His requirement was further complicated by the fact that the documents he wished to deal with were attachments to e-mail messages. This caused some head scratching, but thanks to fellow MVPs Doug Robbins and especially Peter Jamieson, who provided the bulk of the code, I came up with the following which saves the attachment of the most recent message in the indicated folder to the folder shown in blue.

Sub ExtractAttachment()

'Create this macro in Word

'It requires a reference in vba tools > references

'to the Outlook object library e.g.

'Microsoft Outlook 12.0 object library
Dim i As Long
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.Folder
Dim olItem As Outlook.MailItem
Dim olAtt As Outlook.Attachment
Dim strFolder As String

'Name the path to the folder where the attachments are to be saved

strFolder = "D:\My Documents\Test\Versions\Odd\Outlook\"

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err = 429 Then
     Set olApp = CreateObject("Outlook.Application")
End If

Set olNs = olApp.GetNamespace("MAPI")
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders("Euro")
i = olFolder.Items.Count
Set olItem = olFolder.Items(i)
If olItem.Attachments.Count > 0 Then
     Set olAtt = olItem.Attachments(1)
     olAtt.SaveAsFile strFolder & olAtt.FileName
     Set olAtt = Nothing
End If
Set olItem = Nothing
Set olFolder = Nothing
Set olNs = Nothing
Set olApp = Nothing
'Call the macro to process the document if required
Call ExtractEUR

End Sub

This set me thinking that I could adapt the code to extract the body of the message and thus give me the choice of whether I started my daily exchange rate extraction from Outlook or Word.

In practice the two provide the same results, but the macro runs faster when starting from Word.

Sub ExtractOLMessage()
Dim i As Long
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.Folder
Dim olItem As Outlook.MailItem
Dim tempDoc As Document

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err = 429 Then
Set olApp = CreateObject("Outlook.Application")
End If

Set olNs = olApp.GetNamespace("MAPI")
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders("Euro")
i = olFolder.Items.Count
Set olItem = olFolder.Items(i)
Set tempDoc = Documents.Add
tempDoc.Content.InsertAfter olItem.Body
olItem.UnRead = False
Set olItem = Nothing
Set olItem = Nothing
Set olFolder = Nothing
Set olNs = Nothing
Set olApp = Nothing

'Call the macro to process the document if required
Call ExtractEUR
End Sub

As this page is concerned primarily with the technique of extracting e-mail data/attachments using vba, I have not reproduced the macro ExtractEUR called by the above macros, which is concerned with a particular reporting requirement of my own.