Exporting Messages to Excel using VBA

[paul h]

I found this bit of code online and have managed to run it with partial success. What I would like to do is narrow it down to scan a single folder and export the messages to an Excel file. Running it on the entire mailbox either takes to long or it errors out. I'm a novice Outlook programmer, though I have some experience in Access and Excel. I'm posting the entire module here, two subs and three functions. I'm hoping an Outlook guru can help me sort it out and simplify it.

Thanks,

Paul

Const MACRO_NAME = "OST2XLS"
Dim excApp As Object, _
    excWkb As Object, _
    excWks As Object, _
    intVersion As Integer, _
    intMessages As Integer, _
    lngRow As Long
 
Sub ExportMessagesToExcel()
    Dim strFilename As String, olkSto As Outlook.Store
    strFilename = InputBox("C:\email\rejects.xls", MACRO_NAME)
    If strFilename <> "" Then
        intMessages = 0
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add
        For Each olkSto In Session.Stores
            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"
            End With
            lngRow = 2
            ProcessFolder olkSto.GetRootFolder()
        Next
        excWkb.SaveAs strFilename
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & intMessages & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub
 
 
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
    Next
    Set olkMsg = Nothing
    For Each olkSub In olkFld.Folders
        ProcessFolder olkSub
    Next
    Set olkSub = Nothing
End Sub
 
 
Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function
 
 
Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
End Function
Function SMTP2007(olkMsg As Outlook.MailItem) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

[gmayor]

If you only wish to process one folder, then you need to tell the macro which folder, and remove the sub folder references. The changes required to the first two macros are:

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

[paul h]

Just to clarify, this is the line where I will tell Outlook what folder to scan.

        Set olFolder = olNS.PickFolder

and will I pick the folder by clicking on it?

Also, are the three other functions no longer needed? I don't see them referenced in first two macros. I won't get to test this till this afternoon. I'm looking forward to putting it through its paces.

[paul h]

I got my answers to the questions above. I easily picked out my folder. I ran the code as written and bumped into several problems which I will iterate. The code checks for olkMsg.Class = olMail. For my purposes this does not work. I am looking at Mail Delivery System Undeliverable notifications. For it to read any of these I had to comment out the If olkMsg.Class = olMail and End If. The next item was a

Type Mismatch

on the GetSMTPAddress(olkMsg, intVersion) and then

Outlook doesn't support this property or method

for olkMsg.RecerivedTime and olkMsg.ReceivedByName which I assume are not properties of notifications. I commented those three lines out and the code finished running. When it came time to save the files it took about 10 minutes, but it finally finished. The end product though was an empty file except for the headers. The objective is to collect all the email addresses found in the notification files and a few scattered messages. If I could get this code to just run for all the notifications it would be a big help.

[paul h]

Last chapter here. I've run both the original version on the messages and the modified version on the notifications. The messages came out fine. The notifications file came out literally full of Chinese characters. I'd post a picture, but I am unable to upload it.

Here's a sample. I'm not sure if this will display correctly.

格浴㹬格慥㹤਍洼瑥⁡瑨灴攭畱癩∽潃瑮湥⵴祔数•潣瑮湥㵴琢硥⽴瑨汭※档牡敳㵴獵愭捳楩㸢⼼敨摡㰾潢祤ാ㰊 㹰戼㰾潦瑮挠汯牯∽〣〰㘰∶猠穩㵥㌢•慦散∽牁慩≬䐾汥癩牥⁹慨⁳慦汩摥琠桴獥⁥敲楣楰湥獴漠⁲牧畯獰㰺 是湯㹴⼼㹢⼼㹰਍昼湯⁴

Is there alternative way of harvesting this data?

[gmayor]

I don't have any ability to read Chinese, but Google translate suggests that this is spam. I am not sure why you would want to store this information? Might you not be better served by a decent spam filter. I have used MailWasher for years without problem.

[paul h]

This is not spam. These are all

Mail Delivery System
Undeliverable

messages.

Each one has an email address that was undeliverable.
I am trying to export these messages to Excel so I can harvest all these addresses.
The code does not capture this correctly, hence the "Chinese".