Consulting

Results 1 to 2 of 2

Thread: Count Emails in Folder/Subfolder in Current Month

  1. #1

    Count Emails in Folder/Subfolder in Current Month

    OK, cross post - but no reply on Mr Excel. So I thought I would ask here.

    I need some VBA to count the emails in a shared mailbox for the current month.

    This code here, works well but shows things by month only, and the order of the months is out. Can someone please help change so it shows by month (in the correct order), and subfolder?

    For Example

    Subfolder
    2019-12 - number of emails
    2020-1 - number of emails

    Subfolder 2
    2019-11 - number of emails
    2019-12 - number of emails
    2020-1 - number of emails

    etc etc


    Sub HowManyEmails()
    
        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 = Application.Session.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"
    
    
        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 ("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
    
    
        ' 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) & "-"
    End Function
    Last edited by hmltnangel; 08-27-2020 at 03:30 AM.

  2. #2
    The following should give you the count of the selected folder and its sub-folders for the current month. If there are many sub-folders it could take a while to run.

    Sub CountMail()
    'Graham Mayor - https://www.gmayor.com - Last updated - 30 Aug 2020
    Dim strCount As String
    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
        strCount = "Mesaages for " & Format(Date, "mmmm yyyy") & vbCr & vbCr
        Do While cFolders.Count > 0
            Set olFolder = cFolders(1)
            cFolders.Remove 1
            strCount = strCount & olFolder.Name & vbTab & ProcessFolder(olFolder) & vbCr
            ' Debug.Print olfolder.Name & vbTab & olfolder.items.Count
            For Each SubFolder In olFolder.folders
                cFolders.Add SubFolder
            Next SubFolder
        Loop
        MsgBox strCount
    lbl_Exit:
        Set olFolder = Nothing
        Set SubFolder = Nothing
        Exit Sub
    err_Handler:
        GoTo lbl_Exit
    End Sub
    
    Function ProcessFolder(olFldr As Folder) As Integer
    'Graham Mayor - https://www.gmayor.com - Last updated - 31 Aug 2020
    Dim olItem As Object
    Dim dDate As Date
    Dim i As Integer, j As Integer
        j = 0
        olFldr.items.Sort "[Received]", True
        For i = olFldr.items.Count To 1 Step -1
            Set olItem = olFldr.items(i)
            dDate = Left(olItem.ReceivedTime, 10)
            If Month(dDate) = Month(Date) And Year(dDate) = Year(Date) Then
                j = j + 1
            Else
                Exit For
            End If
            DoEvents
        Next i
        ProcessFolder = j
    lbl_Exit:
        Set olItem = Nothing
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •