Question

我使用以下代码在Outlook中进行选择：

Dim conversations As Outlook.Selection
Set conversations = Application.ActiveExplorer.Selection.GetSelection(Outlook.OlSelectionContents.olConversationHeaders)

我必须使用不同的方法来遍历对话，电子邮件等，并根据选区的位置进行错误处理。例如，Outlook搜索文件夹的过程与标准文件夹的过程不同。

我想特别了解所选内容是否在Outlook搜索文件夹中。

可以做到吗？

Answer 1

这将指示某项（不一定是所选内容）是否在搜索文件夹中。

Option Explicit

Private Sub SearchFolder_Items()

    Dim acctStr As String
    Dim mailboxStr As String

    Dim objItm As Object
    Dim objFldrItm As Object

    Dim colStores As stores

    Dim oSearchFolders As Folders
    Dim oFolder As Folder

    Dim i As Long

    Dim colItems As Items
    Dim colItemsRes As Items

    Dim srchFldrItm As Object

    Dim subjSingleQuote As String

    Dim subjNoReFW As String
    Dim strFilter As String

    Dim foundFlag As Boolean

    mailboxStr = const_emAddress    '   <-- your "email address" in quotes
    acctStr = Session.Accounts(mailboxStr)

    Set objItm = ActiveExplorer.Selection(1)

    Set colStores = Session.stores

    For i = 1 To colStores.count

        If colStores(i) = acctStr Then

            Set oSearchFolders = colStores(i).GetSearchFolders

            If InStr(objItm.subject, Chr(39)) Then

                Debug.Print " objItm.subject.....: " & objItm.subject & " contains a single quote."
                Debug.Print " The restrict filter does not accommodate the single quote Chr(39)"
                Debug.Print "  this way will be slow."

                For Each oFolder In oSearchFolders

                    Debug.Print " SearchFolder.......: " & oFolder.name

                    For Each objFldrItm In oFolder.Items

                        DoEvents

                        If objItm.entryID = objFldrItm.entryID Then

                            Debug.Print
                            Debug.Print objItm.subject & " is in search folder: " & oFolder.name
                            Debug.Print

                            foundFlag = True

                        End If

                    Next

                Next

            Else

                ' Interesting wrinkle just discovered
                ' Must remove "RE: " and "FW: " from subject in search folder
                If Left(objItm.subject, 4) = "RE: " Then
                    subjNoReFW = Right(objItm.subject, Len(objItm.subject) - 4)

                ElseIf Left(objItm.subject, 4) = "FW: " Then
                    subjNoReFW = Right(objItm.subject, Len(objItm.subject) - 4)

                Else
                    subjNoReFW = objItm.subject
                End If

                strFilter = "[Subject] = '" & subjNoReFW & "'"

                For Each oFolder In oSearchFolders

                    DoEvents

                    Set colItems = oFolder.Items
                    Set colItemsRes = colItems.Restrict(strFilter)

                    If colItemsRes.count > 0 Then

                        For Each srchFldrItm In colItemsRes

                            If objItm.entryID = srchFldrItm.entryID Then

                                Debug.Print
                                Debug.Print objItm.subject & vbCr & " in search folder: " & oFolder.name

                                foundFlag = True

                            End If

                        Next

                    End If

                Next

           End If

        End If

    Next

    If foundFlag = False Then

        Debug.Print vbCr & objItm.subject & vbCr & " not found in a search folder."

    End If

ExitRoutine:

    Debug.Print
    Debug.Print objItm.subject & vbCr & " is in folder: " & objItm.Parent

    Debug.Print
    Debug.Print "Done"

End Sub

如何检查选择是否在Outlook搜索文件夹中

1 个答案: