How to count emails from various folders and subfolders of Outlook using vba in excel

[sachin483]

I am trying to count the number of emails from different folders and subfolders of Outlook using vba. I also want the output to show the date of the last email in these folders in excel worksheet, i am using outlook 2019

[HansV]

Copy the following code into a module, then run CountMessages.

Code: Select all

Private w As Worksheet
Private r As Long

Sub CountMessages()
    Dim objOL As Object ' Outlook.Application
    Dim objNsp As Object ' Outlook.Namespace
    Dim objFld As Object ' Outlook.Folder
    Dim f As Boolean
    Application.ScreenUpdating = False
    Set w = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    w.Range("A1:C1").Value = Array("Folder", "Number of Items", "Most Recent Item")
    r = 1
    On Error Resume Next
    Set objOL = GetObject(Class:="Outlook.Application")
    If objOL Is Nothing Then
        Set objOL = CreateObject(Class:="Outlook.Application")
        f = True
    End If
    On Error GoTo ErrHandler
    Set objNsp = objOL.GetNamespace("MAPI")
    For Each objFld In objNsp.Folders
        ProcessFolder objFld
    Next objFld
    w.Range("A1:C1").EntireColumn.AutoFit
ExitHandler:
    On Error Resume Next
    If f Then
        objOL.Quit
    End If
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

Sub ProcessFolder(objFld As Object) ' Outlook.Folder
    Dim objSfl As Object ' Outlook.Folder
    Dim objItm As Object
    Dim f As Boolean
    Dim n As Long
    Dim d As Date
    Dim dm As Date
    dm = #1/1/100#
    For Each objItm In objFld.Items
        If objItm.Class = 43 Then ' 43 = olMail
            f = True
            n = n + 1
            d = objItm.ReceivedTime
            If d > dm Then dm = d
        End If
    Next objItm
    If f Then
        r = r + 1
        w.Range("A" & r).Resize(1, 3).Value = Array(objFld.FolderPath, n, dm)
    End If
    For Each objSfl In objFld.Folders
        ProcessFolder objSfl
    Next objSfl
End Sub

[sachin483]

Thanks a lot working fine for all the folders but can we select the folder in prompt and range of dates

[HansV]

Here you go:

Code: Select all

Private w As Worksheet
Private r As Long

Sub CountMessages()
    Dim objOL As Object ' Outlook.Application
    Dim objNsp As Object ' Outlook.Namespace
    Dim objFld As Object ' Outlook.Folder
    Dim f As Boolean
    Dim dFrom As Date
    Dim dTo As Date
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOL = GetObject(Class:="Outlook.Application")
    If objOL Is Nothing Then
        Set objOL = CreateObject(Class:="Outlook.Application")
        f = True
    End If
    On Error GoTo ErrHandler
    Set objNsp = objOL.GetNamespace("MAPI")
    Set objFld = objNsp.PickFolder
    If objFld Is Nothing Then
        Exit Sub
    End If
    On Error GoTo ExitHandler
    dFrom = InputBox("Enter the start date")
    dTo = InputBox("Enter the end date")
    On Error GoTo ErrHandler
    Set w = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    w.Range("A1:C1").Value = Array("Folder", "Number of Items", "Most Recent Item")
    r = 1
    ProcessFolder objFld, dFrom, dTo
    w.Range("A1:C1").EntireColumn.AutoFit
ExitHandler:
    On Error Resume Next
    If f Then
        objOL.Quit
    End If
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

Sub ProcessFolder(objFld As Object, dFrom As Date, dTo As Date) ' Outlook.Folder
    Dim objSfl As Object ' Outlook.Folder
    Dim objItm As Object
    Dim f As Boolean
    Dim n As Long
    Dim d As Date
    Dim dm As Date
    dm = #1/1/100#
    For Each objItm In objFld.Items
        If objItm.Class = 43 Then ' 43 = olMail
            d = objItm.ReceivedTime
            If d >= dFrom And d <= dTo Then
                f = True
                n = n + 1
                If d > dm Then dm = d
            End If
        End If
    Next objItm
    If f Then
        r = r + 1
        w.Range("A" & r).Resize(1, 3).Value = Array(objFld.FolderPath, n, dm)
    End If
    For Each objSfl In objFld.Folders
        ProcessFolder objSfl, dFrom, dTo
    Next objSfl
End Sub

[sachin483]

Thanks a lot working fine but it's showing most recent date and I want to count how many mails sent on every date depends on parameter date

[HansV]

The macro counts ALL email received within the specified date range, and it also displays the date of the most recent email within that range.
Is that not what you want?

[sachin483]

Ie ;_ in a month individual date count eg on 1 day recd 5 email on 2 date 25 email received

[HansV]

That's quite different from what you originally asked...

Code: Select all

Private w As Worksheet
Private r As Long

Sub CountMessages()
    Dim objOL As Object ' Outlook.Application
    Dim objNsp As Object ' Outlook.Namespace
    Dim objFld As Object ' Outlook.Folder
    Dim f As Boolean
    Dim dFrom As Date
    Dim dTo As Date
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOL = GetObject(Class:="Outlook.Application")
    If objOL Is Nothing Then
        Set objOL = CreateObject(Class:="Outlook.Application")
        f = True
    End If
    On Error GoTo ErrHandler
    Set objNsp = objOL.GetNamespace("MAPI")
    Set objFld = objNsp.PickFolder
    If objFld Is Nothing Then
        Exit Sub
    End If
    On Error GoTo ExitHandler
    dFrom = InputBox("Enter the start date")
    dTo = InputBox("Enter the end date")
    On Error GoTo ErrHandler
    Set w = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    w.Range("A1:C1").Value = Array("Folder", "Date", "Number of Items")
    r = 1
    ProcessFolder objFld, dFrom, dTo
    w.Range("A1:C1").EntireColumn.AutoFit
ExitHandler:
    On Error Resume Next
    If f Then
        objOL.Quit
    End If
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

Sub ProcessFolder(objFld As Object, dFrom As Date, dTo As Date) ' Outlook.Folder
    Dim objSfl As Object ' Outlook.Folder
    Dim objItm As Object
    Dim d As Date
    ReDim n(dFrom To dTo) As Long
    For Each objItm In objFld.Items
        If objItm.Class = 43 Then ' 43 = olMail
            d = Int(objItm.ReceivedTime)
            If d >= dFrom And d <= dTo Then
                n(d) = n(d) + 1
            End If
        End If
    Next objItm
    For d = dFrom To dTo
        If n(d) > 0 Then
            r = r + 1
            w.Range("A" & r).Resize(1, 3).Value = Array(objFld.FolderPath, d, n(d))
        End If
    Next d
    For Each objSfl In objFld.Folders
        ProcessFolder objSfl, dFrom, dTo
    Next objSfl
End Sub

[sachin483]

Thanks a lot working fine this was because I had sent 4 to 5 thousand mail on different date and not able to tally