How to count emails in subfolders of a shared mailbox?

Question

I want to count the number of emails in seven subfolders of a shared mailbox.
I also want the date of the last email in these folders.

The shared mailbox looks like

>"Shared Mailbox Name"
>>Inbox
>>>Folder one
>>>>A
>>>>B
>>>>C
>>>Folder two
>>>>D
>>>>E
>>>>F
>>>>G

I want the result to show number of emails of all these folders together and not one by one. A, B, C, D, E, F, G.

I managed to get the number of emails for one folder at a time.

Type TmyCount
    item As Date
    count As Integer
End Type


Sub Steuerung()
    
    
    Dim objNS As Outlook.NameSpace
    Dim objFolder As Outlook.MAPIFolder
    Set objNS = GetNamespace("MAPI")
   Set objFolder = objNS.Folders("shared mailbox name") 'folders of your current account
    
    'Creates a new Excel workbook
    Dim oXL As Object
    Set oXL = CreateObject("Excel.Application")
    Set oWB = oXL.Workbooks.Add
    oWB.sheets(1).Cells(2, 1).Value = "Date/Day"
    
    'Creates a list to which folders to be counted can be appended
    Dim colList As Collection
    Set colList = New Collection
    
    Set objFolder = objFolder.Folders("Inbox")
    Set objFolder = objFolder.Folders("Folder one")
    Set objFolder = objFolder.Folders("A")
    'Set objFolder = objFolder.Folders("B")
    
    
    'Adds all subfolders of 'Inbound chargeback processing' to the list
    Dim subF As Outlook.MAPIFolder
    For Each subF In objFolder.Folders
        colList.Add subF
    Next subF
    
     'SampleCode to add new folders to the edit list
     Set objFolder = objNS.Folders("shared mailbox name") ' folders of your current account
     Set objFolder = objFolder.Folders("Inbox")
     Set objFolder = objFolder.Folders("A")
     'Set objFolder = objFolder.Folders("B")
     colList.Add objFolder
       
     
    '-----------------------------------------------------------------------------------------------------------------
    'Please enter folders to be processed above this line
    
    'Iterates over the folder list and counts all mails and enters the values in the Excel workbook
    Dim k As Integer
    For k = 1 To colList.count
        Call Arrayfüllen(colList.item(k), k)
    Next k
    
    
    oWB.sheets(1).Cells(2, 2 * k).Value = "ReklaSumme"
    oWB.sheets(1).Cells(2, 2 * k + 1).Value = "ScanSumme"
    
    Dim n As Integer
    n = 3
    
    Dim countRekla As Integer
    
    Dim countScan As Integer
    
    While oWB.sheets(1).Cells(n, 1) <> ""
        countScan = 0
        countRekla = 0
        
        For m = 2 To 2 * k - 2
            
            If m Mod 2 = 1 Then
                
                countScan = countScan + oWB.sheets(1).Cells(n, m).Value
                 
            Else
                
                countRekla = countRekla + oWB.sheets(1).Cells(n, m).Value
                
            End If
            
        Next m
        
        oWB.sheets(1).Cells(n, 2 * k).Value = CStr(countRekla)
        oWB.sheets(1).Cells(n, 2 * k + 1).Value = CStr(countScan)
        
        n = n + 1
    Wend
    
    
    
    'Makes the Excel workbooks visible
    oXL.Visible = True
    
End Sub

Sub Arrayfüllen(objFolder As Outlook.MAPIFolder, position As Integer)
    'Fills the objFolder folder's messages into two different arrays depending on the sender
    
    Dim Message As Object

    Dim arraysizeRekla As Integer
    arraysizeRekla = 0
    Dim arraysizeScan As Integer
    arraysizeScan = 0
    
    Dim msgInhaltRekla() As String
    Dim msgInhaltScan() As String
    
    For Each Message In objFolder.Items
        'Iterates over all items in the folder
        If Message.Class = 43 Then
            'If the message is from then 
            If Message.SenderName = "Jonas, Adamski" Then
                'If it is a sender, fill the date in the msgContentScan array
                ReDim Preserve msgInhaltScan(arraysizeScan)
                msgInhaltScan(arraysizeScan) = Format(Message.ReceivedTime, "dd.mm.yyyy")
                arraysizeScan = arraysizeScan + 1
            
            Else
                'Otherwise, fill the date in the msgContentRekla array
                ReDim Preserve msgInhaltRekla(arraysizeRekla)
                msgInhaltRekla(arraysizeRekla) = Format(Message.ReceivedTime, "dd.mm.yyyy")
                arraysizeRekla = arraysizeRekla + 1
            
            End If
            
        Else
            'Falls es sich um ein Terminobjekt etc. handelt
        End If
    Next
    
    
    Dim reklaErgebnis() As TmyCount
    reklaErgebnis = ArrayVerarbeiten(msgInhaltRekla)
    'reklaEregbnis is filled with the aggregated result from msg InhaltRekla
    Dim scanErgebnis() As TmyCount
    scanErgebnis = ArrayVerarbeiten(msgInhaltScan)
    'scanResult is filled with the aggregated result from msgContentScan
   
    
    
    
    'Creates the heading in the Excel document
    oWB.sheets(1).Cells(1, 2 * position).Value = objFolder.Name
    oWB.sheets(1).Cells(2, 2 * position).Value = "Rekla"
    oWB.sheets(1).Cells(2, 2 * position + 1).Value = "Scan"
    
    Dim j As Integer
    
    If IsArrayEmpty(reklaErgebnis) = False Then
        'If array reklaResult is not empty
        
        For i = 0 To UBound(reklaErgebnis)
            'Go through the whole array
            
            j = 3
            While oWB.sheets(1).Cells(j, 1).Value <> reklaErgebnis(i).item And oWB.sheets(1).Cells(j, 1).Value <> vbNullString
                'Find suitable date or navigate to the end
                j = j + 1
            Wend
       
            If oWB.sheets(1).Cells(j, 1).Value <> reklaErgebnis(i).item Then
                'Empty line at the end
                oWB.sheets(1).Cells(j, 1).Value = reklaErgebnis(i).item
                oWB.sheets(1).Cells(j, 2 * position).Value = reklaErgebnis(i).count
            
            Else
                'Date line found
                oWB.sheets(1).Cells(j, 2 * position).Value = reklaErgebnis(i).count
            End If
        
        Next
        
    End If

    
    
    If IsArrayEmpty(scanErgebnis) = False Then
        'If Array scanResult is not empty
        
        For i = 0 To UBound(scanErgebnis)
        
            j = 3
            While oWB.sheets(1).Cells(j, 1).Value <> scanErgebnis(i).item And oWB.sheets(1).Cells(j, 1).Value <> vbNullString
                'Find suitable date or navigate to the end
                j = j + 1
            Wend
        
            If oWB.sheets(1).Cells(j, 1).Value <> scanErgebnis(i).item Then
                'Empty line at the end
                oWB.sheets(1).Cells(j, 1).Value = scanErgebnis(i).item
                oWB.sheets(1).Cells(j, 2 * position + 1).Value = scanErgebnis(i).count
            
            Else
                'Date line found
                oWB.sheets(1).Cells(j, 2 * position + 1).Value = scanErgebnis(i).count
            End If
            
        Next
        
    End If

    
End Sub
Function ArrayVerarbeiten(ByRef msgInhalt() As String) As TmyCount()
    'Aggregates msgContent by the dates, counting the occurrences
    
    Dim icount As Integer
    Dim acount() As TmyCount
    Dim i As Integer, index As Integer
    
    If IsStringArrayEmpty(msgInhalt) Then
        'If msgContent is not initialized, an uninitialized item is returned
        ArrayVerarbeiten = acount
        Exit Function
    End If
    
    icount = -1
    For i = 0 To UBound(msgInhalt)
        index = IsInArray(icount, acount, msgInhalt(i))
        If index < 0 Then
            icount = icount + 1
            ReDim Preserve acount(icount)
            acount(icount).item = msgInhalt(i)
            acount(icount).count = 1
        Else
            acount(index).count = acount(index).count + 1
        End If
    Next
    
    ArrayVerarbeiten = acount
    
End Function


Function IsInArray(icount As Integer, acount() As TmyCount, ele As String) As Integer
    'Prüft, ob ele in account enthalten ist
    'Prüft nur die Elemente an den Stellen < icount
    
    Dim i As Integer
    IsInArray = -1
    For i = 0 To icount
        If acount(i).item = ele Then
            IsInArray = i
            Exit Function
        End If
    Next
End Function


Function IsArrayEmpty(anArray() As TmyCount) As Boolean
    'Checks whether a TmyCount array has not been initialized
    
    Dim i As Integer

    On Error Resume Next
        i = UBound(anArray, 1)
    Select Case (Err.Number)
        Case 9
            IsArrayEmpty = True
        Case Else
            IsArrayEmpty = False
    End Select
End Function

Function IsStringArrayEmpty(anArray() As String) As Boolean
    'Checks whether a string array is uninitialized
    
    Dim i As Integer

    On Error Resume Next
    i = UBound(anArray, 1)
    Select Case (Err.Number)
        Case 9
           IsStringArrayEmpty = True
        Case Else
            IsStringArrayEmpty = False
    End Select
End Function```


**And this is the code to iterate over all folder recursively.**

    Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)

        Dim oFolder As Outlook.MAPIFolder
        Dim oMail As Outlook.MailItem

        Debug.Print(oParent.Items.Count)    

        For Each oMail In oParent.Items

        'Get your data here ...

        Next

        If (oParent.Folders.Count > 0) Then
            For Each oFolder In oParent.Folders
                processFolder oFolder
            Next
        End If
End Sub

Answer 1

You can use the following code to get the latest item:

Sub Sample()
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
    Dim myItems As Items
    Dim myItem As MailItem

    Set objNS = GetNamespace("MAPI")
    Set objFolder = objNS.GetDefaultFolder(olFolderInbox)

    Set myItems = objFolder.Items
    myItems.Sort "ReceivedTime", True

    If myItems.Count > 0 Then
        Set myItem = myItems.Item(1)

        Debug.Print myItem.ReceivedTime
    Else
        Msgbox "This folder doesn't have any emails/items"
    End If
End Sub

Answer 2

Firstly, lCurrentItemsCount parameter must be declared ByRef to make it an in/out parameter.

To get the date of the latest email, retrieve the Items collection from MAPIFolder.Items , call Items.Sort to sort of the ReceivedTime property, then call Items.GetFirst to get back the MailItem object. Use MailItem.ReceivedTime property.