How to count emails from various folders and subfolders of Outlook using vba?-CodePudding

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. My code only gets the count and date from one folder at a time but I want them all at once. This is ow the shared email looks with its folders and subfolders.

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

Dim oWB As Object

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

CodePudding user response：

You need to iterate over all folder recursively to count the number of items. The following code shows how to iterate over all subfolders in Outlook:

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

CodePudding user response：

I have the same problem @EugeneAstafiev It would be helpful if you could add the codes because I need a code to count all the emails in every folder and subfolder of a shared inbox.