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.
- Outlook 2007 – 2010.
- Any version of Windows.
- The spreadsheet(s) must already exist.
- The computer must be on for the task scheduler to function.
- Open Notepad.
- Copy the code below and paste it into Notepad.
- Edit the code as needed. I’ve included comments where changes can/should be made.
- Save the file with a .vbs extension. You can name it anything you want.
- Create a scheduled task that runs periodically. You can set the frequency to whatever you want.
- 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
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.