VBA to track daily received email counts and subject lines

[JimDandy]

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:


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"
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.

[gmayor]

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.


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

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

[JimDandy]

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!

[JimDandy]

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.

[gmayor]

If you change

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

If InStr(1, oNi.Body, CStr(Date) & "....Message Count ....") > 0 Then
you should get a new note each day.

[JimDandy]

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