Exporting Outlook Message Counts to Excel

I’m writing this post in response to a comment Shaima Alsaif left on my “Exporting Outlook Messages to Excel” entry from this last October. In the comment Shaima asked if it’s possible to alter the export to do the following:

• Get message counts instead of messages
• Add to the spreadsheet instead of overwriting it
• Have the process run automatically each week

The answer to all three is “yes”. Doing this requires taking a different approach from the one I used in the original solution. The biggest change is that this solution uses VBScript instead of VBA. Here’s why. Outlook does not have a built-in means of scheduling code to run. It’s possible to get around that (e.g. using a repeating task coupled with an event handler that traps the ReminderFire event), but it’s better to use a true scheduler like the one built into Windows (i.e. Task Scheduler). To the best of my knowledge Windows Task Scheduler cannot call a VBA routine, hence the need to use VBScript instead.

Here is how the new script will meet Shaima’s requirements. Getting the message count is easy. Each Outlook folder stores its content in a collection called Items. This collection includes a Count property that denotes the number of items in the folder. As a side note, if we wanted the unread item count, then we’d look to the folder itself instead of its Items collection. Since the solution shouldn’t overwrite the Excel workbook each time we need to alter the original code to open an existing workbook instead of creating a new one each time. We also have to add code to find the last used row in the spreadsheet the message count will be written to. Once we have this we’ll add 1 to it so the new value is written to the next available line. Scheduling the script is easy. All that requires is creating a new Windows Task that calls the script and setting it to run at whatever the desired interval is.

Requirements.

• Outlook 2007 – 2010.
• Any version of Windows.
• The spreadsheet(s) must already exist.
• The computer must be on for the task scheduler to function.

Instructions.

1. Open Notepad.
2. Copy the code below and paste it into Notepad.
3. Edit the code as needed. I’ve included comments where changes can/should be made.
4. Save the file with a .vbs extension. You can name it anything you want.
5. Create a scheduled task that runs periodically. You can set the frequency to whatever you want.
6. Set the task to run this script.

'Declare some variables
Dim olkApp, olkSes

'Connect to Outlook
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = olkApp.GetNamespace("MAPI")
olkSes.Logon olkApp.DefaultProfileName

'Call the export process once for each folder count to be exported
'Format is ExportMessageCountToExcel <Path to Outlook Folder>, <Path and filename of the Excel file to export to>, <Number of the sheet the count goes on>
'The following lines are examples.  Edit them as needed.  Add additional lines as desired.
ExportMessageCountToExcel "Mailbox - Doe, John\Inbox", "C:\Message_Counts.xlsx", 1
ExportMessageCountToExcel "Personal Folders\Projects", "C:\Message_Counts.xlsx", 2

'Disconnect from Outlook
olkSes.Logoff
Set olkSes = Nothing
Set olkApp = Nothing
WScript.Quit

Sub ExportMessageCountToExcel(strFolder, strWorkbook, intSheet)
    Const EXCEL_COL = 1
    Dim olkFld, excApp, excWkb, excWks, lngRow
    Set olkFld = OpenOutlookFolder(strFolder)
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Open(strWorkbook)
    Set excWks = excWkb.Worksheets(intSheet)
    lngRow = excWks.UsedRange.Rows.Count
    If lngRow = 1 Then 
        If excWks.Cells(lngRow,1) <> "" Then
            lngRow = lngRow + 1
        End If
    Else
        lngRow = lngRow + 1
    End If
    excWks.Cells(lngRow, EXCEL_COL) = olkFld.Items.Count
    Set excWks = Nothing
    excWkb.Close True
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    Set olkFld = Nothing
End Sub

Function OpenOutlookFolder(strFolderPath)
    Dim arrFolders, varFolder, bolBeyondRoot
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = olkApp.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number <> 0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function

Notes.

Here are a few thoughts on how the code could be extended to create additional functionality.

• Create the spreadsheet if it does not exist.
• Get both the item and unread item counts. Right now it only reports the item count.
• Get the counts for a folder and all its subfolders.
• Record the date the count was recorded on.