Option Explicit
Sub ListMessages()
Dim wdApp As Object
Dim wdDoc As Object
Dim oTable As Object
Dim bStarted As Boolean
Dim oRng As Object
Dim olFolder As Folder
Dim olItem As MailItem
    Set olFolder = Application.Session.PickFolder
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
        bStarted = True
    End If
    On Error GoTo err_Handler
    Set wdDoc = wdApp.Documents.Add
    Set oTable = wdDoc.Tables.Add(wdDoc.Range, 1, 2)
    Set oRng = oTable.Rows.Last.Cells(1).Range
    oRng.End = oRng.End - 1
    oRng.Text = "Message"
    Set oRng = oTable.Rows.Last.Cells(2).Range
    oRng.End = oRng.End - 1
    oRng.Text = "Date"
    wdApp.Visible = True
    wdApp.Activate
    Set oRng = wdDoc.Range
    For Each olItem In olFolder.Items
        oTable.Rows.Add
        Set oRng = oTable.Rows.Last.Cells(1).Range
        oRng.End = oRng.End - 1
        oRng.Text = olItem.Subject
        Set oRng = oTable.Rows.Last.Cells(2).Range
        oRng.End = oRng.End - 1
        oRng.Text = Format(olItem.ReceivedTime, "dd/mm/yyyy")
    Next olItem
lbl_Exit:
    If bStarted = True Then
        wdApp.Quit
    End If
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Exit Sub
err_Handler:
    MsgBox Err.Number & vbCr & Err.Description
    Err.Clear
    GoTo lbl_Exit
End Sub