Outlook VBA e-mail count per day

[MelanievL]

Hi all,

I'm trying to make a VBA that will provide me with details of e-mails received in a specific folder+sub folders per selected day.

I'm working with Outlook 365 on Windows 10
The folder is an inbox of an account of which I'm not the owner(mailbox used by multiple users)

I found a VBA which works, but only gives me the total count of e-mails in that mailbox.

Sub CountItems()
Dim objMainFolder As Outlook.folder
Dim lItemsCount As Long
'Select a folder
Set objMainFolder = Outlook.Application.Session.PickFolder
If objMainFolder Is Nothing Then
    MsgBox "You choose select a valid folder!", vbExclamation + vbOKOnly, "Warning for Pick Folder"
Else
    'Initialize the total count
    lItemsCount = 0
    Call LoopFolders(objMainFolder, lItemsCount)
End If
'Display a message for the total count
MsgBox "There are " & lItemsCount & " items in the " & objMainFolder.Name & " folder Including its subfolders.", vbInformation, "Count Items"
End Sub

Sub LoopFolders(ByVal objCurrentFolder As Outlook.folder, lCurrentItemsCount As Long)
Dim objSubfolder As Outlook.folder
lCurrentItemsCount = lCurrentItemsCount + objCurrentFolder.Items.Count
'Process all folders and subfolders recursively
If objCurrentFolder.Folders.Count Then
    For Each objSubfolder In objCurrentFolder.Folders
        Call LoopFolders(objSubfolder, lCurrentItemsCount)
    Next
End If
End Sub

And I have found another one that gives me the items per selected date, but only works on my personal folder.

Sub Countemailsperday()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Dim oDate As String
oDate = InputBox("Type the date for count (format YYYY-m-d")
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = Application.ActiveExplorer.CurrentFolder
If Err.Number <> 0 Then
    Err.Clear
    MsgBox "No such folder."
    Exit Sub
End If
EmailCount = objFolder.Items.Count
MsgBox "Number of emails in the folder: " & EmailCount, , "email count"
Dim ssitem As MailItem
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Set dict = CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
myItems.SetColumns ("ReceivedTime")
' Determine date of each message:
For Each myItem In myItems
    dateStr = GetDate(myItem.ReceivedTime)
    If dateStr = oDate Then
        If Not dict.Exists(dateStr) Then
            dict(dateStr) = 0
        End If
        dict(dateStr) = CLng(dict(dateStr)) + 1
    End If
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 objnSpace = Nothing
Set objOutlook = Nothing
End Sub

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

Can someone help me find a combined VBA which gives me the desired outcome?

This would be very very helpfull and I could never thank you enough.