VBA循环遍历所有收件箱，包括共享收件箱

Question

我有工作代码可以根据主题回复用户 Outlook 中的电子邮件。但是，我无法通过所有用户的收件箱进行代码搜索。

到目前为止，它只会搜索用户的特定收件箱。这是我的代码，我已经四处搜索，但找不到我的 VBA 知识可以理解的解决方案。

Sub Display()

    Dim Fldr As Outlook.Folder
    Dim olfolder As Outlook.MAPIFolder
    Dim olMail As Outlook.MailItem
    Dim olReply As Outlook.MailItem
    Dim olItems As Outlook.Items
    Dim i As Integer
    Dim signature As String

    Set Fldr = Session.GetDefaultFolder(olFolderInbox)
    Set olItems = Fldr.Items

    olItems.Sort "[Received]", True

    For i = 1 To olItems.count
        signature = Environ("appdata") & "\Microsoft\Signatures\"

        If Dir(signature, vbDirectory) <> vbNullString Then
            signature = signature & Dir$(signature & "*.htm")
        Else
            signature = ""
        End If

        signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll

        Set olMail = olItems(i)

        If InStr(olMail.Subject, Worksheets("Checklist Form").Range("B8")) <> 0 Then
            If Not olMail.Categories = "Executed" Then
                Set olReply = olMail.ReplyAll

                With olReply
                    .HTMLBody = "<p style='font-family:calibri;font-size:14.5'>" & "Hi Everyone," & _
                        "<p style='font-family:calibri;font-size:14.5'>" & "Workflow ID:" & " " & _
                        Worksheets("Checklist Form").Range("B6") & "<p style='font-family:calibri;font-size:14.5'>" & _
                        Worksheets("Checklist Form").Range("B11") & "<p style='font-family:calibri;font-size:14.5'>" & _
                        "Regards," & "</p><br>" & signature & .HTMLBody
                    .Display
                    .Subject = "RO Finalized WF:" & Worksheets("Checklist Form").Range("B6") & " " & _
                        Worksheets("Checklist Form").Range("B2") & " -" & Worksheets("Fulfillment Checklist").Range("B3")
                End With

                Exit For
                olMail.Categories = "Executed"

            End If
        End If

    Next i

End Sub

Answer 1

您可以像这样引用任何收件箱：

Option Explicit

Sub Inbox_by_Store()

Dim allStores As Stores
Dim storeInbox As Folder

Dim j As Long

Set allStores = Session.Stores

For j = 1 To allStores.count

    Debug.Print j & " DisplayName - " & allStores(j).DisplayName

    Set storeInbox = Nothing

    ' Some stores will not have an inbox
    ' Bypass possible expected error if there is no inbox in the store
    On Error Resume Next
    ' Note this is one of the rare acceptable uses for On Error Resume Next
    Set storeInbox = allStores(j).GetDefaultFolder(olFolderInbox)
    ' Turn off error bypass as soon as it is no longer needed
    On Error GoTo 0

    If Not storeInbox Is Nothing Then
        storeInbox.Display

        ' your code here instead of storeInbox.Display
        ' Set Fldr = storeInbox

    End If

Next

ExitRoutine:
    Set allStores = Nothing
    Set storeInbox = Nothing

End Sub

Answer 2

我真的没有能力测试这是否有效，但这些是我在 cmets 中提到的更改，我希望它们有效！

Sub Display()

    '...

    Set Fldr = Session.GetDefaultFolder(olFolderInbox)

    Dim mySubfolder As Outlook.Folder       'added
    For Each mySubfolder In Fldr.Folders    'added

        Set olItems = mySubfolder.Items     'changed

        For i = 1 To olItems.count

        '...

        Next i

    Next mySubfolder                        'added

End Sub