Question

我使用此代码的目的是根据主题（B8）在用户的视角下回复特定的电子邮件。本质上，代码会遍历用户的所有收件箱（包括共享收件箱）以查找电子邮件。

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

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"跳到底部的If结束。

我想也许可以将“结尾”移到"If not storeinbox Is Nothing Then"的正下方，但是会发生错误"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

Answer 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

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

1 个答案: