Consulting

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
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  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
    to
    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
    http://www.gmayor.com

  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
  •