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 saw Sterling in terminal decline and by 2010 had barely improved .

To facilitate this I receive a daily e-mailed update from www.xe.com (now in html format) 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. The messages are automatically diverted to an Inbox sub folder in Outlook called "Euro" using Outlooks rules.

I am only interested in the GBP entry (highlighted in red).

The extracted data is added, to a a new row of a three column table in a Word document defined in sFname as shown below. Weekends are coloured in a pale orange.

The macro reads the most recent message in a Mail folder named 'Euro', and having extracted the data the message is marked as read.

Option Explicit

'Create this macro in Word

'It requires a reference in vba tools > references

'to the Outlook object library e.g. for Outlook 2007

'Microsoft Outlook 12.0 object library

Sub ExtractOLMessage()
Dim sFname As String
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 oDoc As Document
Dim oTable As Table
Dim oRow As Row
Dim sText As String
Dim strEuros As String
Dim strGBP As String
Dim bStarted As Boolean
Dim vText As Variant
Dim sDate As String
Dim sDay As String
Dim sMonth As String
Dim sYear As String

bStarted = False 'Set a flag

'Document containing the table
sFname = "D:\My Documents\Test\Euro exchange data.docx"
'If the document is open, set it as the active document

If ActiveDocument.FullName = sFname Then
    Set oDoc = ActiveDocument
Else   'otherwise open it
    Set oDoc = Documents.Open(FileName:=sFname)
    bStarted = True 'And set the flag to true
End If
Set oTable = oDoc.Tables(1)
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err = 429 Then 'Outlook is closed so open it
    Set olApp = CreateObject("Outlook.Application")
End If
Set olNs = olApp.GetNamespace("MAPI")

'Indicate which Outlook folder to access
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders("Euro")

'Indicate the last message
Set olItem = olFolder.Items(olFolder.Items.Count)

'Get the text of the message
sText = olItem.Body

'and split it by paragraph
vText = Split(sText, Chr(13))

'Examine each paragraph
For i = 1 To UBound(vText)

    'and locate the text relating to the item required
    If InStr(1, vText(i), "GBP United Kingdom Pounds") Then

        'The Euros entry '1.1347362692' in the example is two paragraphs after the found paragraph
        strEuros = vText(i + 2)

        'The Pounds entry '0.8812620405' in the example is four paragraphs after the found paragraph
        strGBP = vText(i + 4)

        'Log the date the message was sent
        sDate = Format(olItem.SentOn, "dd.MM.yyyy")

        'The entry has been found so stop looking for it
        Exit For
    End If
Next i

'Mark the message as read
olItem.UnRead = False

'Then clear the Outlook variables
Set olItem = Nothing
Set olItem = Nothing
Set olFolder = Nothing
Set olNs = Nothing
Set olApp = Nothing

'Add another row to the table
Set oRow = oTable.Rows.Add

'and fill the cells in that row with the extracted data
oRow.Cells(1).Range = sDate
oRow.Cells(2).Range = strEuros
oRow.Cells(2).Range = Replace(oRow.Cells(2).Range, Chr(13), "")
oRow.Cells(3).Range = strGBP
oRow.Cells(3).Range = Replace(oRow.Cells(3).Range, Chr(13), "")
'Establish whether the date is a Saturday or a Sunday
sMonth = MonthName(Mid(sDate, 4, 2))
sDay = Left(sDate, 2)
sYear = Right(sDate, 4)
sDate = sDay & Chr(32) & sMonth & Chr(32) & sYear
sDate = WeekDay(sDate)
If sDate = 1 Or sDate = 7 Then 'it is a weekend
    'So colour the date cell