The code is essentially the same. You will need a two column worksheet with a header row i.e. Sheet1 of C:\Path\Email Log.xlsx (change the path as required)
The Date will be column 1. The count will be column 2.
Change yourdomain.com to your company domain name in order to exclude internal messages.
Change the date switches "dd/mm/yyyy" to suit local requirements
The macro counts the messages sent on the current day, so in practice you would run the macro after the last mail of the day in order to correctly record the count.
The message box is optional.
Sub CountSent()
'Graham Mayor - https://www.gmayor.com - Last updated - 24 Sep 2019
Const strWB As String = "C:\Path\Email Log.xlsx"
Const strSheet As String = "Sheet1"
Dim strDate As String
Dim strValues As String
Dim olFolder As Folder
Dim olItem As Object
Dim lngItem As Long
Dim lngCount As Long: lngCount = 0
Set olFolder = Session.GetDefaultFolder(olFolderSentMail)
For lngItem = olFolder.items.Count To 1 Step -1
Set olItem = olFolder.items(lngItem)
If TypeName(olItem) = "MailItem" Then 'count only e-mails
If CDate(Format(olItem.SentOn, "dd/mm/yyyy")) = CDate(Format(Date, "dd/mm/yyyy")) Then 'test for today's messages
If Not olItem.Recipients(1).Address Like "*@yourdomain.com" Then 'ignore internal messages
strDate = Format(olItem.SentOn, "dd/mm/yyyy")
lngCount = lngCount + 1
End If
Else
Exit For
End If
End If
DoEvents
Next lngItem
strValues = strDate & "', '" & CStr(lngCount)
WriteToWorksheet strWorkbook:=strWB, strRange:="Sheet1", strValues:=strValues
lbl_Exit:
MsgBox lngCount & " items sent"
Set olFolder = Nothing
Set olItem = Nothing
Exit Sub
End Sub
Private Function WriteToWorksheet(strWorkbook As String, _
strRange As String, _
strValues As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
lbl_Exit:
Set CN = Nothing
Exit Function
End Function