Option Explicit

Const MACRO_NAME = "OST2XLS"
Private excApp As Object, _
    excWkb As Object, _
    excWks As Object, _
    intVersion As Integer, _
    intMessages As Integer, _
    lngRow As Long

Sub ExportMessagesToExcel()
Dim strFilename As String
Dim olNS As NameSpace
Dim olFolder As Folder
Dim fso As Object

strFilename = InputBox("Enter path to save workbook", MACRO_NAME, "C:\email\rejects.xls")    'Folder must exist!
    If strFilename <> "" Then
        Set fso = CreateObject("Scripting.FileSystemObject")
        If Not (fso.FolderExists(Left(strFilename, InStrRev(strFilename, Chr(92))))) Then
            MsgBox "The folder " & Left(strFilename, InStrRev(strFilename, Chr(92))) & " does not exist!"
            GoTo lbl_Exit
        End If
        intMessages = 0
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add
        'excApp.Visible = True    'for testing
        Set olNS = GetNamespace("MAPI")
        Set olFolder = olNS.PickFolder
        Set excWks = excWkb.Worksheets.Add()
        excWks.Name = "Output"
        'Write Excel Column Headers
        With excWks
            .cells(1, 1) = "Folder"
            .cells(1, 2) = "Sender"
            .cells(1, 3) = "Received"
            .cells(1, 4) = "Sent To"
            .cells(1, 5) = "Subject"
            .cells(1, 6) = "Body"
            With .UsedRange
                .ColumnWidth = 22
                .HorizontalAlignment = 1
                .VerticalAlignment = -4160
                .WrapText = True
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = -5002
                .MergeCells = False
            End With
        End With
        lngRow = 2
        ProcessFolder olFolder
        excWkb.SaveAs strFilename
    End If
    excApp.Quit
    MsgBox "Process complete.  A total of " & intMessages & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
lbl_Exit:
    Set fso = Nothing
    Set excWks = Nothing
    Set excWkb = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set excApp = Nothing
    Exit Sub
End Sub
 

Private Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
    Dim olkMsg As Object ', olkSub As Outlook.MAPIFolder
    'Write messages to spreadsheet
    For Each olkMsg In olkFld.Items
        'Only export messages, not receipts or appointment requests, etc.
        If olkMsg.Class = olMail Then
            'Add a row for each field in the message you want to export
            excWks.cells(lngRow, 1) = olkFld.Name
            excWks.cells(lngRow, 2) = GetSMTPAddress(olkMsg, intVersion)
            excWks.cells(lngRow, 3) = olkMsg.ReceivedTime
            excWks.cells(lngRow, 4) = olkMsg.ReceivedByName
            excWks.cells(lngRow, 5) = olkMsg.subject
            excWks.cells(lngRow, 6) = olkMsg.Body
            lngRow = lngRow + 1
            intMessages = intMessages + 1
        End If
        DoEvents 'Add this line
    Next
    Set olkMsg = Nothing
    'For Each olkSub In olkFld.folders
    '    ProcessFolder olkSub
    'Next
    'Set olkSub = Nothing
End Sub