Outlook statistics with VBA
Have you ever wondered how many emails you get everyday or send ever day? Nearly 43% of my time went in reading and responding to emails. That is a lot of time away from core development. There weren’t software I could find online to run outlook statistics about the number of emails I sent, break it down by date dimension or by sender or by subject. So I decided to take snippets of code, analyze the Outlook model and roll my own VBA; one could very well do with C# COM Interop. Finally, I just chose to use VBA for fun.
' We will explicitly declare all variables using ' Dim or ReDim keywords. This is good practice Option Explicit ' Let's declare a constant string that holds Const FOLDER_OF_INTEREST As String = "LargeOldEmails2" ' In LargeOldEmails2, I will try to find all emails in Inbox folder Const MAILFOLDER As String = "Inbox" ' This is the data variable I'll write to the report Dim data As String ' I'll store the report here Const REPORTFILE As String = "e:\vbadata.txt" ' Let me put together some headers so that it can be neatly ' imported into a database or even Excel. We'll make this file ' tab separated Const HEADERS As String = "CreationTime" & vbTab & _ "LastModificationTime" & vbTab & _ "Subject" & vbTab & _ "SenderName" & vbTab & _ "SentOn" & vbTab & _ "To" & vbTab & _ "ReceivedTime" ' List all accounts I have in Outlook, but just stop when ' we find the top level folder of interest Sub ListAccounts() ' Let's get the current application's session Dim Session As Outlook.NameSpace Set Session = Application.Session ' Now let's get top level accounts. They are ' folders according to Outlook Dim Folders As Outlook.Folders Set Folders = Session.Folders ' Now that we have a collection of folders, let's ' list each folder's name. If we find a folder that ' we are interested in, let's stop at that point Dim Folder As Outlook.Folder Dim FolderOfInterestFound As Boolean FolderOfInterestFound = False For Each Folder In Folders ' I am interested only in Sent Items top level folder ' When I see it, just stop looping. If Folder.Name = FOLDER_OF_INTEREST Then FolderOfInterestFound = True Exit For End If Next ' Let's list all folders in this top level folder until ' we find a folder of interest RecurseFolders Folder ' Let's do recursion to populate data variable with a list of tab-delimited ' dataset. Write this data to a file WriteData MsgBox "Done" Exit Sub End Sub ' We will make a procedure to write the report Private Sub WriteData() Dim freefil As Integer freefil = FreeFile() Open REPORTFILE For Output As freefil Print #freefil, HEADERS Print #freefil, data Close #freefil End Sub ' Given a folder, let's list out all the folders and send them to this ' same procedure again. In the process, read the email properties ' if there are any emails in that folder Private Sub RecurseFolders(ByVal CurrentFolder As Outlook.Folder) ' If this is the folder we want and if there are mail items, only then ' proceed further If CurrentFolder.Name = MAILFOLDER And _ CurrentFolder.Items.Count > 0 Then ' set up items and properties Dim itms As Outlook.Items Dim itm As Object Dim itmprops As Outlook.ItemProperties Set itms = CurrentFolder.Items ' Evaluate each item that is a mail item and build a ' tab-delimited dataset. Properties have to be in the right ' case For Each itm In itms If itm.Class = olMail Then data = data & _ itm.ItemProperties.Item("CreationTime").Value & vbTab & _ itm.ItemProperties.Item("LastModificationTime").Value & vbTab & _ itm.ItemProperties.Item("Subject").Value & vbTab & _ itm.ItemProperties.Item("SenderName").Value & vbTab & _ itm.ItemProperties.Item("SentOn").Value & vbTab & _ itm.ItemProperties.Item("To").Value & vbTab & _ itm.ItemProperties.Item("ReceivedTime").Value & vbCrLf 'If it is desired to list all properties, run a counter 'to list out all property names and their values. In some 'cases, printing of item's value won't work and an exception 'will be thrown. In that case, step into the code to find out 'which property throws an error (perhaps because it is returning 'a collection rather than just a value) 'Exit For 'Debug.Print itm.ItemProperties.Item.Count 'For i = 0 To 90 ' Debug.Print i & "-" & itm.ItemProperties.Item(i).Name 'Next End If Next End If ' Does this folder have more folders? Yes? Let's list all ' the subfolders and subject them to this same procedure ' to list more emails If CurrentFolder.Folders.Count > 0 Then ' loop through the folders in this current folder Dim SubFolders As Outlook.Folders Dim SubFolder As Outlook.Folder Set SubFolders = CurrentFolder.Folders For Each SubFolder In SubFolders ' write down the path to the subfolder and then recurse Debug.Print SubFolder.FolderPath RecurseFolders SubFolder 'if it is desired to run through only one folder, the 'for-each loop can be stopped like so: 'Exit For Next SubFolder End If Exit Sub End Sub
This process can be modified to list out properties of all emails from all folders and run thorough statistics.