如何计算共享邮箱子文件夹中的电子邮件？

Question

我想统计共享邮箱的七个子文件夹中的电子邮件数量。
我还想要这些文件夹中最后一封电子邮件的日期。

共享邮箱的样子

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

我希望结果显示所有这些文件夹的电子邮件数量，而不是一一显示。 A、B、C、D、E、F、G。

我设法一次获取一个文件夹的电子邮件数量。

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

您可以使用以下代码获取最新项目：

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

首先，lCurrentItemsCount 参数必须声明为ByRef 以使其成为输入/输出参数。

要获取最新电子邮件的日期，请从MAPIFolder.Items 检索Items 集合，调用Items.Sort 对ReceivedTime 属性进行排序，然后调用Items.GetFirst 以取回MailItem 对象。使用MailItem.ReceivedTime 属性。