Once in a blue moon I have a need to analyze emails in my Outlook, I would need to get my emails into structural data so I could run my analysis and statistics. I have come across this article, and thought I would re-post it with abridged steps.

  1. Start Outlook
  2. Hit ALT-F11, and Visual Basic for Applications should show
  3. Choose Insert -> Module
  4. Copy and Paste the following source code into the Edit
  5. Choose Tools -> References, and make sure that Microsoft Excel is part of the reference
  6. Hit F5 and Run, pick the folder you wish to Outlook export the mails from
' The source code is adopted from
' http://www.techrepublic.com/blog/msoffice/quickly-export-outlook-e-mail-items-to-excel/744
Sub ExportToExcel()
    On Error GoTo ErrHandler
    
    Dim appExcel As Excel.Application
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim rng As Excel.Range
    Dim strSheet As String
    Dim strPath As String
    Dim intRowCounter As Integer
    Dim intColumnCounter As Integer
    Dim msg As Outlook.MailItem
    Dim nms As Outlook.NameSpace
    Dim fld As Outlook.MAPIFolder
    Dim itm As Object
    
    strSheet = "OutlookItems.xlsx"
    strPath = "c:\"

    strSheet = strPath & strSheet
    Debug.Print strSheet

    'Select export folder
    Set nms = Application.GetNamespace("MAPI")
    Set fld = nms.PickFolder

    'Handle potential errors with Select Folder dialog box.
    If fld Is Nothing Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    ElseIf fld.DefaultItemType  olMailItem Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    ElseIf fld.Items.Count = 0 Then
        MsgBox "There are no mail messages to export", vbOKOnly, "Error"
        Exit Sub
    End If

    'Open and activate Excel workbook.
    Set appExcel = CreateObject("Excel.Application")
    appExcel.Workbooks.Open (strSheet)
    Set wkb = appExcel.ActiveWorkbook
    Set wks = wkb.Sheets(1)
    wks.Activate
    
    appExcel.Application.Visible = True
    'Copy field items in mail folder.
    For Each itm In fld.Items
        intColumnCounter = 1
        Set msg = itm
        intRowCounter = intRowCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.To
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.SenderEmailAddress
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.Subject
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.SentOn
        intColumnCounter = intColumnCounter + 1
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.ReceivedTime
    Next itm
    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
    
    Exit Sub
ErrHandler:      If Err.Number = 1004 Then
        MsgBox strSheet & " doesn't exist, please create a empty spreadsheet at the location before running this Macro", vbOKOnly, "Error"
    Else
        MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"
    End If
    
    Set appExcel = Nothing
    Set wkb = Nothing
    Set wks = Nothing
    Set rng = Nothing
    Set msg = Nothing
    Set nms = Nothing
    Set fld = Nothing
    Set itm = Nothing
End Sub
About these ads