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.
    Last edited by Aussiebear; 04-23-2023 at 04:44 PM. Reason: Adjusted the code tags

  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
    Last edited by Aussiebear; 04-23-2023 at 04:52 PM. Reason: Reduced the whitespace
    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
    Last edited by Aussiebear; 04-23-2023 at 04:54 PM. Reason: Adjusted the whitespace
    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.
    Last edited by Aussiebear; 04-23-2023 at 04:55 PM. Reason: Reduced the whitespace
    Gruß, Wolfgang

  10. #10
    VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,433
    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
  •