Код не выполняется, потому что объект не поддерживает свойство фильтра - PullRequest
Новая
       7

Код не выполняется, потому что объект не поддерживает свойство фильтра

0 голосов
/ 07 февраля 2019

Я не могу отфильтровать выбранный почтовый элемент по теме.Проблема заключается в том, что 

If TypeOf Items(1) Is Outlook.MailItem And Items(1).Restrict(sFilter) Then

вызывает ошибку

Ошибка времени выполнения 438: объект не поддерживает это свойство или метод.

Шаги:

  1. Прокручивание ячеек для различных имен субъектов
  2. Поиск в папках «Входящие» и «Sentitem» последних сообщений электронной почты по выбранной теме «Тема», поскольку иногда люди не отвечают на ваши сообщения.Таким образом, последнее электронное письмо находится в отправленных элементах, а не в вашем почтовом ящике
  3. выберите последнее электронное письмо и ответьте на все
  4. Для основной части письма я запускаю другую функцию для получения необходимой информации,

Код: 

Sub AccessInbox6()
'Early binding
    Dim Olook As Outlook.Application ' to access all the libraries of outlook

    Set Olook = New Outlook.Application
    Dim sFilter As String
    Dim sSubject As String


  ' Restrict items and running the loop

    Sheet1.Range("A2").Select

    Do Until ActiveCell.Value = "" 'Using this to loop over multiple cells containing subjects

        sSubject = ActiveCell.Value
        sFilter = "[Subject] = '" & sSubject & "'"


        Dim Items As Outlook.Items
        Set Items = Olook.GetNamespace("MAPI") _
                         .GetDefaultFolder(olFolderInbox).Items 'Checking the inbox

        Dim Items2 As Outlook.Items
        Set Items2 = Olook.GetNamespace("MAPI") _
                         .GetDefaultFolder(olFolderSentMail).Items 'Checking the sent items


        Items.Sort "ReceivedTime", True 'to put them in order by date
        Items2.Sort "ReceivedTime", True 'to put them in order by date or I should use "SentOn"
        'Items2.Sort "SentOn", True


        If Items.Item(1).ReceivedTime > Items2.Item(1).ReceivedTime Then 'Here I am checking which email is latest by date either in inbox or SentItems

            If TypeOf Items(1) Is Outlook.MailItem And Items(1).Restrict(sFilter) Then 'Getting error here - Here I am checking if the "Subject of the email matches with what I have in the excel sheet

                 Debug.Print Items(1).Subject ' Print on Immediate Window

                       With Items(1).ReplyAll
                            .Display
                            .Body = "Dear Someone" & vbNewLine & vbNewLine & GetPSMUpdate2 & vbNewLine & vbNewLine & "Sincerely," & vbNewLine & "XX-"

                            '.Attachments.Add Environ("UserProfile") & "\Desktop\Tracking Sheet.xlsx"

                            .To = "XXX@gmail.com"
                            .Subject = "PSM Report"
                            '.Send
                        End With
                        Else
                          MsgBox "No emails found with Subject:" & vbLf & "'" & sSubject & "'"

            End If


        Else

            If TypeOf Items2(1) Is Outlook.MailItem And Items2(1).Restrict(sFilter) Then

                 Debug.Print Items(1).Subject ' Print on Immediate Window

                       With Items(1).ReplyAll
                            .Display
                            .Body = "Dear Someone" & vbNewLine & vbNewLine & GetPSMUpdate2 & vbNewLine & vbNewLine & "Sincerely," & vbNewLine & "XX-"

                            '.Attachments.Add Environ("UserProfile") & "\Desktop\Tracking Sheet.xlsx"

                            .To = "XXX@gmail.com"
                            .Subject = "PSM Report"
                            '.Send
                        End With
                        Else
                          MsgBox "No emails found with Subject:" & vbLf & "'" & sSubject & "'"

            End If
        End If

        ActiveCell.Offset(1, 0).Select

    Loop

End Sub

Function GetPSMUpdate2() As String

 Dim PSMColumn As Range, PSMRow As Range, r As Range, C As Range

 Dim Str As String

 Sheet2.Activate

 Set PSMColumn = Range("A2", Range("A1").End(xlDown))

    For Each r In PSMColumn

        Set PSMRow = Range(r, r.End(xlToRight))

        For Each C In PSMRow

            Str = Str & C.Value

            If C.Column < r.End(xlToRight).Column Then

            Str = Str & vbTab
            End If

        Next C

        If r.Row < Range("A1").End(xlDown).Row Then

            Str = Str & vbNewLine

        End If

    Next r

GetPSMUpdate2 = Str

End Function
...