Outlook Inbox to Excel

Attribute VB_Name = "OutlookInboxToExcel"
'===============================================================
' OutlookInboxToExcel.bas
'
' Excel VBA module that connects to a running Outlook instance
' and dumps Subject / Sender / ReceivedTime / Unread status for
' every item in the Inbox into the active sheet, newest first.
'
' Requirements:
'   - Outlook must be installed (does not need to be already open;
'     the macro will start it via COM automation if needed).
'   - In VBA editor: Tools > References > check
'     "Microsoft Outlook xx.0 Object Library" for full IntelliSense
'     (the code below uses late binding, so this is optional).
'
' Usage:
'   1. Alt+F11, import this module (or paste into a new one).
'   2. Select the sheet you want the data in, run ImportInboxToActiveSheet.
'===============================================================
Option Explicit

Public Sub ImportInboxToActiveSheet()
    Dim olApp As Object          ' Outlook.Application
    Dim olNs As Object           ' Outlook.NameSpace
    Dim olInbox As Object        ' Outlook.MAPIFolder
    Dim olItem As Object
    Dim ws As Worksheet
    Dim r As Long
    Dim wasAlreadyRunning As Boolean

    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    On Error GoTo 0

    If olApp Is Nothing Then
        Set olApp = CreateObject("Outlook.Application")
        wasAlreadyRunning = False
    Else
        wasAlreadyRunning = True
    End If

    Set olNs = olApp.GetNamespace("MAPI")
    Set olInbox = olNs.GetDefaultFolder(6) ' 6 = olFolderInbox

    Set ws = ActiveSheet
    ws.Cells.Clear
    ws.Range("A1:D1").Value = Array("Subject", "Sender", "Received", "Unread")
    ws.Range("A1:D1").Font.Bold = True

    r = 2
    Dim itms As Object
    Set itms = olInbox.Items
    itms.Sort "[ReceivedTime]", True ' descending, newest first

    For Each olItem In itms
        If TypeName(olItem) = "MailItem" Then
            ws.Cells(r, 1).Value = olItem.Subject
            ws.Cells(r, 2).Value = olItem.SenderName
            ws.Cells(r, 3).Value = olItem.ReceivedTime
            ws.Cells(r, 4).Value = olItem.UnRead
            r = r + 1
        End If
    Next olItem

    ws.Columns("A:D").AutoFit

    If Not wasAlreadyRunning Then
        olApp.Quit
    End If

    MsgBox (r - 2) & " message(s) imported.", vbInformation
End Sub