Consulting

Results 1 to 10 of 10

Thread: Outlook VBA e-mail count per day

  1. #1

    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.

    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.

  2. #2
    The first macro allows you to pick the folder.
    Set objMainFolder = Outlook.Application.Session.PickFolder
    The second uses a fixed folder location
    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

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    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!

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

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

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

    When i click on debug it shows highlighted here:
    error vba.jpg

  6. #6
    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?
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  7. #7
    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.

  8. #8
    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.

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  9. #9
    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.

    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.
    Gruß, Wolfgang

  10. #10
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,315
    Location
    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)
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

Posting Permissions

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