On Error GoTo ErrorHandlerExit

Dim oNameSpace As Outlook.NameSpace Dim oFolder As Outlook.MAPIFolder

Dim objFS As Scripting.FileSystemObject Dim objOutputFile As Scripting.TextStream

Set objFS = New Scripting.FileSystemObject Set objOutputFile = objFS.OpenTextFile("C:\Temp\Export.csv", ForWriting, True) Set oNameSpace = Application.GetNamespace("MAPI") Set oFolder = oNameSpace.PickFolder

If oFolder Is Nothing Then GoTo ErrorHandlerExit End If

If oFolder.DefaultItemType <> olMailItem Then
  MsgBox "Folder does not contain mail messages"
  GoTo ErrorHandlerExit
End If

objOutputFile.WriteLine "From,Subject,Recived, Body"

ProcessFolderItems oFolder, objOutputFile

objOutputFile.Close

Set oFolder = Nothing
Set oNameSpace = Nothing
Set objOutputFile = Nothing
Set objFS = Nothing

ErrorHandlerExit: Exit Sub

End Sub

Sub ProcessFolderItems(oParentFolder As Outlook.MAPIFolder, ByRef objOutputFile As Scripting.TextStream) Dim oCount As Integer Dim oMail As Outlook.MailItem Dim oFolder As Outlook.MAPIFolder oCount = oParentFolder.Items.Count

For Each oMail In oParentFolder.Items
    If oMail.Class = olMail Then

    objOutputFile.WriteLine oMail.SenderEmailAddress & "," & Replace(oMail.Subject, ",", "") & "," & oMail.ReceivedTime

    End If
Next oMail

Set oMail = Nothing
If (oParentFolder.Folders.Count > 0) Then
        For Each oFolder In oParentFolder.Folders
            ProcessFolderItems oFolder, objOutputFile
        Next
End If

End Sub