VBA to track daily received email counts and subject lines

I am looking for some assistance in building a macro that fires whenever I receive an email. I would like it if the macro could do two things:

1. Keep an active count of the number of emails I have received as each message is received, maybe by creating and updating an email for each day in a folder with a subject of "Mail Received: 11/4/2019 - 121 emails"
2. Add the Date, Subject and Sender's address of each email received into a csv file

Counting emails after the fact doesn't work as I have a series of inbox rules that move messages around and those that don't get moved I usually hard-delete once I've read them.

The following should do the job. It records the day and the count in the registry and should reset the count to 1 when the date changes. The running total is recorded in an Outlook note, which should appear at the top of the notes list.

The main macro is run as a script from a rule that applies to all incoming messages. As you have other rules, order the rules to run this one before the existing rules.

The messages are recorded in a csv file which is created if not present.

I have include a macro to test with a selected message.

Code:

---

Option Explicit

Sub TestMacro()
Dim olMsg As MailItem
    On Error GoTo err_Handler
    Set olMsg = ActiveExplorer.Selection.Item(1)
    GetMessageCount olMsg
lbl_Exit:
    Exit Sub
err_Handler:
    Beep
    If Err.Number = 13 Then
        MsgBox "Select a message first!"
    Else
        MsgBox Err.Number & vbCr & Err.Description
    End If
    Err.Clear
    GoTo lbl_Exit
End Sub


Sub GetMessageCount(olItem As Outlook.MailItem)
Dim strData As String
Dim strText As String
Dim dDate As Date
Dim iCount As Integer
Const strPath As String = "C:\Path\EmailLog.csv"
    With olItem
        strText = Chr(34) & Format(.ReceivedTime, "mm/dd/yyyy") & _
                  Chr(34) & Chr(44) & Chr(34) & .Subject & Chr(34) & Chr(44) & _
                  Chr(34) & .SenderEmailAddress & Chr(34)
        Open strPath For Append As #1
        Print #1, strText
        Close #1
        iCount = CInt(GetSetting("Outlook Message Count", "Data", "Count", 1))
        dDate = CDate(GetSetting("Outlook Message Count", "Data", "Date", Date))
        If Date > dDate Then
            iCount = 1
        Else
            iCount = iCount + 1
        End If
        SaveSetting "Outlook Message Count", "Data", "Date", CStr(Date)
        SaveSetting "Outlook Message Count", "Data", "Count", CStr(iCount)
        SaveCount iCount
    End With
lbl_Exit:
    Exit Sub
End Sub


Sub SaveCount(iCount As Integer)
Dim fNotes As MAPIFolder
Dim oNi As NoteItem
Dim bNote As Boolean
    Set fNotes = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderNotes)
    For Each oNi In fNotes.items
        If InStr(1, oNi.Body, "....Message Count ....") > 0 Then
            bNote = True
            oNi.Body = CStr(Date) & "....Message Count ...." & iCount
            Exit For
        End If
    Next oNi
    If Not bNote Then
        Set oNi = CreateItem(olNoteItem)
        oNi.Body = CStr(Date) & "....Message Count ...." & iCount
    End If
    oNi.Save
lbl_Exit:
    Set fNotes = Nothing
    Set oNi = Nothing
    Exit Sub
End Sub

---

Scripts are blocked by default in the latest Outlook versions. If your version of Outlook is similarly blocked, you can re-enable them using the following macro

Code:

---

Sub ToggleOutlookScripts()Dim wshShell As Object
Dim RegKey As String
Dim rKeyWord As String
Dim wVer As String
    Set wshShell = CreateObject("WScript.Shell")
    wVer = Val(Application.Version) & ".0"
Start:
    RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & wVer & "\Outlook\Security\"
    On Error Resume Next
    'The registry key does not exist
    rKeyWord = wshShell.RegRead(RegKey & "EnableUnsafeClientMailRules")
    If rKeyWord = "" Then
        wshShell.RegWrite RegKey & "EnableUnsafeClientMailRules", 1, "REG_DWORD"    'set it at zero
        GoTo Start:    'and read it again
    End If
    If rKeyWord = 1 Then
        wshShell.RegWrite RegKey & "EnableUnsafeClientMailRules", 0, "REG_DWORD"
        MsgBox "Unsafe Client Mail Rules disabled", vbInformation, "Scripts"
    Else
        wshShell.RegWrite RegKey & "EnableUnsafeClientMailRules", 1, "REG_DWORD"
        MsgBox "Unsafe Client Mail Rules enabled", vbInformation, "Scripts"
    End If
lbl_Exit:
    Exit Sub
End Sub

---

This appears to work great and does just what I needed. I'll keep an eye on it and close out after the date change.

Thank you!

Is there any chance that the new date would create a new Note saving the previous Notes and totals? Otherwise, this works great but I didn't take note before midnight as to the last count. I could derive a count from the csv but that requires a whole bunch of extra steps each day.

If you change

Code:

---

If InStr(1, oNi.Body, "....Message Count ....") > 0 Then

---

to

Code:

---

If InStr(1, oNi.Body, CStr(Date) & "....Message Count ....") > 0 Then

---

you should get a new note each day.

100% functional....I thank you. This is very much appreciated!