问VBA循环访问所有收件箱，包括共享收件箱
EN

Stack Overflow用户

提问于 2018-08-09 15:07:40

回答 2查看 1.1K关注 0票数 0

我有在用户的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

excel

vba

outlook

数字工厂场景解决方案

帮助企业实现数字化、智能化，解决企业工厂内设备数据采集、设备指标分析、企业信息系统间数据孤岛打通、数据应用困难的问题

回答 2

Stack Overflow用户

回答已采纳

发布于 2018-08-10 14:33:47

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

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

票数 1

Stack Overflow用户

发布于 2018-08-09 18:54:29

我真的没有能力测试这是否有效，但这些是我在评论中提到的变化，我希望它们能起作用！

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