I’ve gotten quite a few comments to my Exporting Outlook Messages to Excel post. One of those comments came from a gent named Chris Wimberley. Chris is looking for a way to export a specific set of Outlook folders from a group of mailboxes to Excel on a scheduled basis. He says he needs to do this for “around 30 resource mailboxes” where each mailbox has “between 30 – 50 folders” nested as many as “4 levels” deep. In addition to some basic message information (e.g. subject, sender) Chris also needs to perform two age calculations: the age, in days, since the message arrived and since it was last modified. For each run the process needs to create a new workbook and all the data needs to be written to a single sheet. Chris goes on to say that he’s currently using several different Excel files to pull the information.
My solution is to use VBScript to automate the process entirely. All Chris will need to do is create a recurring task using Windows Task Scheduler that runs the script at whatever interval he needs. The script itself is really very simple. Create a few variables, connect to Outlook, open Excel and create a new workbook, write headers to the first sheet in the new book, process the list of folders using a recursive procedure call, save the workbook, and finally close everything down. For the two calculations I’ve used VBScript’s built-in DateDiff function to get the number of days between the message’s arrival date/modified date and the date the script is being run on.
Hopefully this will take of Chris’ issue. Chris, and anyone else who uses this, needs to be sure and test the script to make sure it works properly before attempting to use it in a production setting. I tested the code prior to posting it here and I believe it’s working properly, but that does not mean it will work properly for you. Test it first!
- Open Notepad.
- Copy the code below and paste it into Notepad.
- Edit the code. I placed comments where things can/should change.
- Save the file. You can name it anything you want. The file extension must be .vbs
'Create some constants 'On the next line edit the path and root name of the workbook the process is to create. The root filename will have -dd.mmm.yyyy.xlsx appended to it. Const BASE_FILENAME = "c:\Users\<username>\Documents\Outlook-" 'Create some variables Dim olkApp, olkSes, excApp, excWkb, excWks, lngRow 'Initialize variables lngRow = 2 'Connect to Outlook Set olkApp = CreateObject("Outlook.Application") Set olkSes = olkApp.GetNamespace("MAPI") olkSes.Logon olkApp.DefaultProfileName 'Connect to Excel Set excApp = CreateObject("Excel.Application") Set excWkb = excApp.Workbooks.Add() Set excWks = excWkb.WorkSheets(1) 'Write the column headers in Excel 'Edit the headers as desired but do not rearrange the columns. With excWks .Cells(1,1) = "Folder" .Cells(1,2) = "Received" .Cells(1,3) = "Age" .Cells(1,4) = "Last Modified" .Cells(1,5) = "Age Since Modified" .Cells(1,6) = "Sender" .Cells(1,7) = "Subject" End With 'Run through the folders. 'On the next line edit the path to the root folder you want to export. That folder and all its sub-folders will be processed. Add an additional line for each top-level folder you want to process. ProcessFolder "Mailbox - Doe, John\Inbox" 'Close Excel excWkb.SaveAs BASE_FILENAME & Day(Date) & "." & MonthName(Month(Date),True) & "." & Year(Date) & ".xlsx" Set excWks = Nothing Set excWkb = Nothing excApp.Quit Set excApp = Nothing 'Close Outlook olkSes.Logoff Set olkSes = Nothing olkApp.Quit Set olkApp = Nothing 'End Processing WScript.Quit Sub ProcessFolder(strFolderPath) Dim olkFld, olkItm, olkSub Set olkFld = OpenOutlookFolder(strFolderPath) If TypeName(olkFld) <> "Nothing" Then For Each olkItm In olkFld.Items excWks.Cells(lngRow,1) = olkItm.Parent.FolderPath excWks.Cells(lngRow,2) = olkItm.ReceivedTime excWks.Cells(lngRow,3) = DateDiff("d", olkItm.ReceivedTime, Now) excWks.Cells(lngRow,4) = olkItm.LastModificationTime excWks.Cells(lngRow,5) = DateDiff("d", olkItm.LastModificationTime, Now) 'Change SenderEmailAddress to Sender if you want the name instead of address excWks.Cells(lngRow,6) = olkItm.SenderEmailAddress excWks.Cells(lngRow,7) = olkItm.Subject lngRow = lngRow + 1 Next For Each olkSub In olkFld.Folders ProcessFolder olkSub.FolderPath Next End If Set olkItm = Nothing Set olkSub = 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 = olkSes.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
To use this solution
- You can run it manually by double-clicking the saved .vbs file.
- To automate running it
- Launch Windows Task Scheduler.
- Create a new task.
- Set the task to run the script
- Set the task to run however often you need. Note that the workbook the script creates has the day in the filename. If you set the task to run more than once a day, then it will overwrite the file each time after the first run of the day.