让 VBA 循环遍历 Outlook 中的所有收件箱，包括共享收件箱

Posted 2023-02-19

【中文标题】让 VBA 循环遍历 Outlook 中的所有收件箱，包括共享收件箱

【英文标题】：Have VBA loop through all inboxes in Outlook including shared inboxes

【发布时间】：2019-01-26 14:53:00

【问题描述】：

我使用此代码的目标是根据主题（B8）回复用户前景中的特定电子邮件。基本上让代码循环遍历所有用户的收件箱，包括共享收件箱以查找电子邮件。

我拥有的第一个代码将进入用户的 Outlook，但只进入他们的主收件箱并拉出电子邮件进行回复。这可以正常工作。

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 Long
    Dim signature As String
    Dim olitem As Object


    Set Fldr = Session.GetDefaultFolder(olFolderInbox)

    Set olitems = Fldr.Items


    olitems.Sort "[Received]", True
    For i = 1 To olitems.Count
        Set olitem = olitems(i)
        If Not TypeOf olitem Is Outlook.MailItem Then GoTo SkipToNext
        Set olMail = olitem
    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," & "Regards," & "</p><br>" & signature & .HTMLBody

                 .Display
                 .Subject               
    End With

                Exit For
                olMail.Categories = "Executed"
                Exit For
                End If
        End If
    SkipToNext:
       Next i

End Sub

这第二部分代码是我的反复试验以及对其他资源的使用尝试让代码循环通过用户的所有收件箱。问题是它不再做任何事情了。

我确实有这个场景的工作代码，然后我错误地保存了它，我没有成功让它恢复工作。下面是我所能得到的最接近的。

任何建议将不胜感激。

第二个脚本似乎从"Set olitems = Fldr.Items" 跳到底部的End If。

如果在"If not storeinbox Is Nothing Then" 正下方，我想可能会移动End，但会出现错误"Object variable or With block variable not set"。

当我更改代码行时（同时进行上述更改）"Set Fldr = Storeinbox" to "Set Fldr = Session.GetDefaultFolder(olFolderInbox)" 电子邮件将填充，但仅在用户的特定收件箱中（不接收主题文本，仅接收最近的电子邮件）。

我在第二个脚本中添加了额外的代码

       Set olitem = olitems(i)
       If Not TypeOf olitem Is Outlook.MailItem Then GoTo SkipToNext
       Set olMail = olitem

缺少的。这将按主题填充用户特定电子邮件地址的电子邮件。如果我从另一个收件箱输入一个主题，那么什么都不会发生，但它会通过代码而没有错误。

越来越近，但共享收件箱仍然没有。

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
    Dim allStores As Stores
    Dim storeInbox As Folder
    Dim j As Long

    Set allStores = Session.Stores

    For j = 1 To allStores.Count
    On Error Resume Next
    Debug.Print j & " DisplayName - " & allStores(j).DisplayName
    On Error GoTo 0

    Set storeInbox = Nothing
    On Error Resume Next
    Set storeInbox = allStores(j).GetDefaultFolder(olFolderInbox)
    On Error GoTo 0

    If Not storeInbox Is Nothing Then
    Set Fldr = storeinbox
     Set olItems = Fldr.Items


    olItems.Sort "[Received]", True

    For i = 1 To olItems.Count
    Set olitem = olitems(i)
        If Not TypeOf olitem Is Outlook.MailItem Then GoTo SkipToNext
        Set olMail = olitem
        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," &
                    "Regards," & "</p><br>" & signature & .HTMLBody
                 .Display
                 .Subject
                End With

                Exit For
                olMail.Categories = "Executed"

            End If
        End If

    Next
    End If

    ExitRoutine:
    Set allStores = Nothing
    Set storeInbox = Nothing
    SkipToNext:
    Next j
End Sub

【问题讨论】：

更改 j 循环以使用 j 索引而不是 I 索引，如此处所示 ***.com/a/51788772/1571407

@niton 抱歉，我没有更新问题中的那部分代码。我确实更改了 j 循环，并且 cmets 关于它如何不起作用的是“缺少哪个。这将填充用户的电子邮件......”位于上方。

【参考方案1】：

如果你在 j 循环内Set allStores = Nothing，它只会在第一次迭代中出现。

Option Explicit

' Think of Option Explicit as being mandatory
' Tools | Options
' Editor tab
' Checkbox "Require Variable Declaration"
' Option Explict will generate automatically on new modules
' You may type it in at the top of an existing module
' This as well points out possible spelling errors in the variables


Sub Display()

    'In Excel set reference to Outlook Object Library

    Dim Fldr As Outlook.Folder

    Dim olMail As Outlook.MailItem
    Dim olItem As Object

    Dim olReply As Outlook.MailItem
    Dim olItems As Outlook.Items

    Dim signature As String

    Dim i As Long
    Dim j As Long

    Dim allStores As Stores
    Dim storeInbox As Folder

    signature = Environ("appdata") & "\Microsoft\Signatures\"

    If Dir(signature, vbDirectory) <> vbNullString Then
        signature = signature & Dir$(signature & "*.htm")
        signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
    Else
        signature = ""
    End If

    ' Usually works with Outlook open.
    ' If this proves to be unreliable,
    '  you may need a CreateObject("Outlook.Application")
    Set allStores = Session.Stores

    For j = 1 To allStores.Count

        ' No need to bypass wrong index error here
        ' The error has been fixed by using j not i
        Debug.Print j & " DisplayName - " & allStores(j).DisplayName

        ' Reset storeInbox to nothing or it will remain the previous
        '  when there is an error on the current store
        ' This is one example of why to be careful with On Error Resume Next
        Set storeInbox = Nothing

        On Error Resume Next
        ' bypass error if store does not have an inbox
        Set storeInbox = allStores(j).GetDefaultFolder(olFolderInbox)
        On Error GoTo 0

        If Not storeInbox Is Nothing Then

            Set Fldr = storeInbox
            Set olItems = Fldr.Items

            ' Not needed?
            'olItems.Sort "[Received]", True

            For i = 1 To olItems.Count

                Set olItem = olItems(i)

                If TypeOf olItem Is Outlook.MailItem Then

                    Set olMail = olItem

                    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," & _
                                  "Regards," & "</p><br>" & signature & .HTMLBody
                                .Display

                                ' Generates a compile error. Appears not needed.
                                '.Subject
                            End With

                            olMail.Categories = "Executed"
                            olMail.Display 'olMail.Save

                        End If
                    End If
                End If
            Next
        End If
    Next j

ExitRoutine:
    Set allStores = Nothing
    Set storeInbox = Nothing

End Sub