Count Emails from a specified Email Address Outlook VBA

[RosieAU]

Hi guys,

I am trying to create a Macro in Outlook for my daily call centre reporting. There is an inbox and then a folder where each agent keeps their completed emails. The figures that I report are as follows:
Emails received (by date)
Emails Open
Date of oldest open email

I've managed to find what I need so far but I have one problem that I can't find any information for. The agents who complete the emails CC the group mailbox when replying to customer emails. I would like to exclude these emails from my count either by excluding emails where the specified email address is in the CC field, or by excluding emails where the sender is a specified email address. Here is what I have so far:

Sub HowManyTASEmails()


Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")


On Error Resume Next
Set objFolder = objnSpace.Folders("TAS").Folders("Inbox")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder Inbox."
Exit Sub
End If

On Error Resume Next
Set objFolderA = objnSpace.Folders("TAS").Folders("Inbox").Folders("Emails - XXXX Completed")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder Emails - XXXX Completed."
Exit Sub
End If

On Error Resume Next
Set objFolderB = objnSpace.Folders("TAS").Folders("Inbox").Folders("Emails - YYYY Completed")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder Emails - YYYY Completed."
Exit Sub
End If

On Error Resume Next
Set objFolderC = objnSpace.Folders("TAS").Folders("Inbox").Folders("Emails - ZZZZ Completed")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder Emails - ZZZZ Completed."
Exit Sub
End If

On Error Resume Next
Set objFolderD = objnSpace.Folders("TAS").Folders("Inbox").Folders("Emails - AAAA Completed")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder Emails - AAAA Completed."
Exit Sub
End If

On Error Resume Next
Set objFolderE = objnSpace.Folders("TAS").Folders("Inbox").Folders("XXXX Agent Emails")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder Emails - XXXX Agent Emails."
Exit Sub
End If

EmailCount = objFolder.Items.Count


MsgBox "Number of emails in the folder: " & EmailCount, , "email count"


objFolder.Items.Sort "[ReceivedTime]", False
Set oldestMessage = objFolder.Items.GetLast
MsgBox "Date of Oldest Open Email: " & oldestMessage.ReceivedTime

Dim dateStr As String
Dim myItems As Outlook.Items
Dim myItemsA As Outlook.Items
Dim myItemsB As Outlook.Items
Dim myItemsC As Outlook.Items
Dim myItemsD As Outlook.Items
Dim myItemsE As Outlook.Items
Dim dict As Object
Dim msg As String
Set dict = CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
Set myItemsA = objFolderA.Items
Set myItemsB = objFolderB.Items
Set myItemsC = objFolderC.Items
Set myItemsD = objFolderD.Items
Set myItemsE = objFolderE.Items
myItems.SetColumns ("SentOn")
' Determine date of each message:
For Each myItem In myItems
dateStr = GetDate(myItem.SentOn)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
myItemsA.SetColumns ("SentOn")
' Determine date of each message:
For Each myItem In myItemsA
dateStr = GetDate(myItem.SentOn)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
myItemsB.SetColumns ("SentOn")
' Determine date of each message:
For Each myItem In myItemsB
dateStr = GetDate(myItem.SentOn)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
myItemsC.SetColumns ("SentOn")
' Determine date of each message:
For Each myItem In myItemsC
dateStr = GetDate(myItem.SentOn)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
myItemsD.SetColumns ("SentOn")
' Determine date of each message:
For Each myItem In myItemsD
dateStr = GetDate(myItem.SentOn)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
myItemsE.SetColumns ("SentOn")
' Determine date of each message:
For Each myItem In myItemsE
dateStr = GetDate(myItem.SentOn)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem


' Output counts per day:
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & " items" & vbCrLf
Next
MsgBox msg


Set objFolder = Nothing
Set objFolderA = Nothing
Set objFolderB = Nothing
Set objFolderC = Nothing
Set objFolderD = Nothing
Set objFolderE = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub


Function GetDate(dt As Date) As String
GetDate = Year(dt) & "-" & Month(dt) & "-" & Day(dt)
End Function


If possible it would be really awesome if the macro could also exclude today's emails but this is not as important as excluding the CC emails.

Thanks!

 

[Domenic]

Try using the Restrict method of the Items collection, which returns a new collection containing all the items from the original that match the filter. So, for example, to return a filtered list of items that excludes a specific email address...

Set myItems= objFolder.Items.Restrict("[SenderEmailAddress] <> 'john@example.com'")

For a count of filtered items...

EmailCount = myItems.Count

Hope this helps!

 

[RosieAU]

Thanks Domenic! For some reason it didn't work with email addresses formatted as john.smith@example.com - I changed it to:
Set myItems = objFolder.Items.Restrict("[From] <> 'Smith, John' ")
And it works great!