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.