Question

我想搜索25个不同的文件夹，而不是硬编码所有这些。文件夹路径对所有人来说都是一样的。文件夹是“邮箱支持中心”/这里不同的人姓名/“已完成”我有下面的前两个，所以你可以看到我在做什么。我想我可以使用a为每个搜索所有邮箱名称，但需要知道如何迭代这些。

Sub CompletedEmailsDailyCount（）

Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim MailItem
Dim EmailCount As Integer, EmailCount1 As Integer, EmailCount2 As Integer, EmailCount3    As     Integer, EmailCount4 As Integer
Dim EmailCount5 As Integer, EmailCount6 As Integer, EmailCount7 As Integer, EmailCount8 As     Integer, EmailCount9 As Integer
Dim EmailCount10 As Integer, EmailCount11 As Integer, EmailCount12 As Integer,     EmailCount13 As Integer, EmailCount14 As Integer
Dim EmailCount15 As Integer, EmailCount16 As Integer, EmailCount17 As Integer,     EmailCount18 As Integer, EmailCount19 As Integer
Dim EmailCount20 As Integer, EmailCount21 As Integer, EmailCount22 As Integer,     EmailCount23 As Integer, EmailCount24 As Integer
Dim EmailCount25 As Integer
Dim completed

Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next

 Set objFolder = objnSpace.Folders("Mailbox - IT Support Center").Folders("Onshore - Josh").Folders("completed")
     On Error GoTo 0
     ' check the folder so it exists
     If objFolder Is Nothing Then MsgBox "No Such Folder": Exit Sub
     ' check through all mailitems in this folder for if the date matches yesterdays, if so, add one to emailcount
     For Each MailItem In objFolder.Items
     If DateValue(Date - 1) = DateValue(MailItem.ReceivedTime) Then EmailCount15 = EmailCount15 + 1
     Next
     completed = completed + EmailCount15 'adds the completes from this mailbox to running total

Set objFolder1 = objnSpace.Folders("Mailbox - IT Support Center").Folders("Onshore - Ashton").Folders("completed")
    On Error GoTo 0
    If objFolder1 Is Nothing Then MsgBox "No Such Folder": Exit Sub
    For Each MailItem In objFolder1.Items
    If DateValue(Date - 1) = DateValue(MailItem.ReceivedTime) Then EmailCount1 = EmailCount1 + 1
    Next
    completed = completed + EmailCount1

Answer 1

未经测试，但这样的事情应该有效：

Sub Tester()

'Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim MailItem
Dim EmailCount() As Integer, arrNames
Dim completed, x As Long, num As Long

    Set objOutlook = CreateObject("Outlook.Application")
    Set objnSpace = objOutlook.GetNamespace("MAPI")

    arrNames = Array("Josh", "Ashton") 'add other names here...
    ReDim EmailCount(LBound(arrNames) To UBound(arrNames))

    For x = LBound(arrNames) To UBound(arrNames)

        On Error Resume Next
        Set objFolder = objnSpace.Folders("Mailbox - IT Support Center"). _
                Folders("Onshore - " & arrNames(x)).Folders("completed")
        On Error GoTo 0

        num = 0
        If Not objFolder Is Nothing Then
            For Each MailItem In objFolder.Items
               If DateValue(Date - 1) = _
                       DateValue(MailItem.ReceivedTime) Then num = num + 1
            Next
        End If
        EmailCount(x) = num
        completed = completed + num

        Debug.Print arrNames(x), num

    Next x

End Sub

vba动态迭代不同的文件夹

1 个答案: