Как проверить, есть ли выбор в папке поиска Outlook

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