Results 1 to 6 of 6

Thread: VBA to track daily received email counts and subject lines

  1. #1

    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.

  2. #2
    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
        Exit Sub
        If Err.Number = 13 Then
            MsgBox "Select a message first!"
            MsgBox Err.Number & vbCr & Err.Description
        End If
        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
                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
        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
        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"
        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"
            wshShell.RegWrite RegKey & "EnableUnsafeClientMailRules", 1, "REG_DWORD"
            MsgBox "Unsafe Client Mail Rules enabled", vbInformation, "Scripts"
        End If
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes

  3. #3
    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!

  4. #4
    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.

  5. #5
    If you change
    If InStr(1, oNi.Body, "....Message Count ....") > 0 Then
    If InStr(1, oNi.Body, CStr(Date) & "....Message Count ....") > 0 Then
    you should get a new note each day.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes

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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts