Outlook VBA e-mail count per day

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.

Code:

---

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.

Code:

---

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.

The first macro allows you to pick the folder.

Code:

---

Set objMainFolder = Outlook.Application.Session.PickFolder

---

The second uses a fixed folder location

Code:

---

Set objFolder = Application.ActiveExplorer.CurrentFolder

---

There is also some superfluous code and some variables are undeclared.
The following is the second macro modified to allow you to pick the folder

Code:

---

Option Explicit
Sub Countemailsperday()
Dim objnSpace As NameSpace, objFolder As MAPIFolder
Dim EmailCount As Integer
Dim oDate As String
Dim ssitem As MailItem
Dim dateStr As String
Dim myItems As Outlook.items
Dim myItem As Object
Dim dict As Object
Dim msg As String
Dim o As Variant
oDate = InputBox("Type the date for count (format YYYY-m-d")
Set objnSpace = Application.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objnSpace.PickFolder
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"
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 myItems = Nothing
End Sub

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

---

Thanks! that's already giving me more than I had. :)

Unfortunately it's still only counting in the main selected folder and not in the sub folders.
As multiple people work in multiple sub folders and changes throughout the day, I really need the count of all+subs.

If anyone can help me out with that, that would be great!

OK to process sub folders you will need to add them to a collection e.g.

Code:

---

Option Explicit

Sub CountEmailsPerDay()
Dim cFolders As Collection, cResults As Collection
Dim olFolder As Outlook.Folder
Dim SubFolder As Folder
Dim olNS As Outlook.NameSpace
Dim i As Long
Dim sList As String, sDate As String
sDate = InputBox("Type the date for count (format YYYY-m-d")
Set cFolders = New Collection
Set cResults = New Collection
Set olNS = GetNamespace("MAPI")
cFolders.Add olNS.PickFolder
MsgBox "This could take a while to process!"
Do While cFolders.Count > 0
    Set olFolder = cFolders(1)
    cFolders.Remove 1
    cResults.Add ProcessFolder(olFolder, sDate)
    For Each SubFolder In olFolder.folders
        cFolders.Add SubFolder
    Next SubFolder
    DoEvents
Loop
For i = 1 To cResults.Count
    sList = sList & cResults(i)
    If i < cResults.Count Then
        sList = sList & vbCr
        DoEvents
    End If
Next i
MsgBox "Messages received on " & sDate & vbCr & vbCr & sList
lbl_Exit:
Set olNS = Nothing
Set olFolder = Nothing
Set SubFolder = Nothing
Set cFolders = Nothing
Set cResults = Nothing
Exit Sub
err_Handler:
    GoTo lbl_Exit
End Sub

Private Function ProcessFolder(iFolder As Folder, sDate As String) As String
Dim i As Long, j As Long
Dim olItem As Outlook.MailItem
Dim sDateStr As String
iFolder.items.SetColumns ("ReceivedTime")
j = 0
For i = 1 To iFolder.items.Count
    Set olItem = iFolder.items(i)
    sDateStr = GetDate(olItem.ReceivedTime)
    If sDateStr = sDate Then
        j = j + 1
    End If
    DoEvents
Next i
ProcessFolder = iFolder.Name & Chr(58) & Chr(32) & j & " items"
lbl_Exit:
Set olItem = Nothing
Exit Function
End Function


Private Function GetDate(dDate As Date) As String
GetDate = Year(dDate) & "-" & Month(dDate) & "-" & Day(dDate)
lbl_Exit:
Exit Function
End Function

---

Almost. I'm getting a runtime error '13'. Type mismatch

When i click on debug it shows highlighted here:
Attachment 26391

I can't immediately think of a reason why this wouldn't work. It works with English regional settings in Windows (runtime error 13 sometimes suggests regional code variations).

I assume that the code I posted is in a standard Module, that there is no other code in that module and the VBA project compiles normally when that module is not present?

I played around with my language settings as it was part Dutch and part English. It's now 'working' but it still only counts the e-mails from the selected folder (Inbox) and not the subfolders.

The collection processes the sub folders. If you run the following macro, which uses the same process, in Outlook it will list all the sub folders for the selected folder in the immediate window of the VBA editor (Ctrl+G). This will be much faster than the mail count.

Code:

---

Sub ListFolders()

Dim cFolders As Collection
Dim olFolder As Outlook.Folder
Dim SubFolder As Folder
Dim olNS As Outlook.NameSpace
Set cFolders = New Collection
Set olNS = GetNamespace("MAPI")
cFolders.Add olNS.PickFolder
MsgBox "This could take a while to process!"
Do While cFolders.Count > 0
    Set olFolder = cFolders(1)
    cFolders.Remove 1
    Debug.Print olFolder.Name
    For Each SubFolder In olFolder.folders
        cFolders.Add SubFolder
    Next SubFolder
    DoEvents
Loop
Set cFolders = Nothing
Set olFolder = Nothing
Set SubFolder = Nothing
Set olNS = Nothing
End Sub

---

Ich hatte gestern diesen Text, mit Makro, bereits in einem Thread von mir selbst eingestellt, in dem ich früher schon einmal hierher verwiesen wurde, nachdem ich mein Problem erörtert hatte.
In den Makros hier geht es in der Regel ja darum, die Mail-Anzahl in Ordnern zu ermitteln, jedoch ohne die Einstellung in Outlook Ordnereigenschaften für die Anzeige zu
ändern.
Ich habe jetzt mal ein Makro angepasst, das ich im Inet gefunden habe und das dann auf mein Bedürfnis angepasst, die Einstellung für die Anzahl hinter den Ordernamen in der Outlook-Navigation umzustellen bzw. die Option zu setzen, dass die Anzahl aller enthaltenen Elemente angezeigt werden soll.

Code:

---

Sub PrivateOrdnerAlleMailsAnzeigen()
Dim xRootFolder As Folder
Dim xFolderCount As Long
Dim xFolder As Object
On Error Resume Next
Neu:
Set xRootFolder = Outlook.Application.Session.PickFolder
If TypeName(xRootFolder) = "Nothing" Then Exit Sub
If xRootFolder.Folders.Count < 1 Then
    MsgBox "No subfolders under " & Chr(34) & xRootFolder.Name & Chr(34) & ".", vbInformation, "Kutools for Outlook"
    Exit Sub
End If
xRootFolder.ShowItemCount = olShowTotalItemCount
For Each xFolder In xRootFolder.Folders
    xFolder.ShowItemCount = olShowTotalItemCount
    xFolderCount = xFolderCount + 1
Next
MsgBox xFolderCount & " Ordner konfiguriert.", vbInformation, "Anzeigeart Elemente im Ordner"
xFolderCount = 1
GoTo Neu
End Sub

---

Es ist erst einmal so etwas, wie eine Lösung für mich, die funktioniert, auch wenn ich mehrere

Male die Ordner manuell auswählen muss, wenn diese vorher ausgewählter Ordner im Unterordner noch weitere Unterordner haben. Beispiel:
Der bei der ersten Auswahl heißt der Ordner "Privates", mit 17 Unterordnern, von denen die Ordner "Einkäufe" und "Telekom" selbst ebenfalls Unterordner haben, so dass die beiden Ordner praktisch wieder neue xRootFolder wären. Wenn jetzt noch jemand eine Idee hat, wie man in der Schleife prüfen lassen kann, ob die zu prüfenden Ordner selbst noch Unterordner haben und

für diese

ebenfalls der Befehl "olShowTotalItemCount" ausgeführt wird, dann wäre es perfekt. Danke schon mal vorab.

Bitte stellen Sie keine Fragen zu gleichen oder verwandten Themen an mehreren Stellen. Diskussion geschlossen. Sie können Ihre ursprüngliche Diskussion fortsetzen: Ordnereigenschaften per VBA aktivieren (vbaexpress.com)