Поиск по теме для последней электронной почты во всех папках и ответить всем

Question

Приведенный ниже код не выполняет функцию answer all all, поэтому я не могу редактировать текст письма и вести цепочку сообщений.

Я думаю, что лучший вариант - это использовать Application.advancesearch, поскольку он дает вам последнюю электронную почту, просматривая все папки.Но я не знаю, как запустить его через Excel.

Цель:
1) Искать в папке «Входящие» и «Подпапки» (несколько папок) и «Отправленные» последние сообщения электронной почты для выбранного «Темы»
2) выбирать последнее сообщение электронной почты и отвечать на все вопросы

Sub ReplyMail()

    ' Variables
    Dim OutlookApp As Object
    Dim IsOutlookCreated As Boolean
    Dim sFilter As String, sSubject As String
    Dim SentTime As Long
    Dim IndoxTime As Long

    Dim olEmailIndox As Outlook.MailItem
    Dim olEmailSent As Outlook.MailItem

    ' Get/create outlook object
    On Error Resume Next
    Set OutlookApp = GetObject(, "Outlook.Application")
    If Err Then
        Set OutlookApp = CreateObject("Outlook.Application")
        IsOutlookCreated = True
    End If
    On Error GoTo 0

    Set olEmailIndox = OutlookApp.CreateItem(olMailItem)
    Set olEmailSent = OutlookApp.CreateItem(olMailItem)



        ' Restrict items
        sSubject = "Subject 1"
        sFilter = "[Subject] = '" & sSubject & "'"

        ' Main
        With OutlookApp.Session.GetDefaultFolder(olFolderSentMail).Items.Restrict(sFilter)
            If .Count > 0 Then
                .Sort "ReceivedTime", True
                Set olEmailSent = .Item(1)
                SentTime = olEmailSent.SentOn
            End If
        End With

        With OutlookApp.Session.GetDefaultFolder(olFolderInbox).Items.Restrict(sFilter)
            If .Count > 0 Then
                .Sort "ReceivedTime", True
                Set olEmailInbox = .Item(1)
                InboxTime = olEmailInbox.ReceivedTime
            End If
        End With

        If SentTime > InboxTime Then
            With olEmailSent
                .ReplyAll
                .Display
                '.body
                '.Send
            End With

        Else
            With olEmailInbox
                .ReplyAll
                .Display
                '.body
                '.Send
            End With

        End If



    ' Quit Outlook instance if it was created by this code
    If IsOutlookCreated Then
        OutlookApp.Quit
        Set OutlookApp = Nothing
    End If

End Sub

Answer 1

Я проверил приведенный ниже код, и хотя вы можете его полировать, вам следует начать.

Дайте мне знать и отметьте ответ, если он поможет.

Добавьте модуль vbaэтот код:

Public Sub ProcessEmails()

    Dim testOutlook As Object
    Dim oOutlook As clsOutlook
    Dim searchRange As Range
    Dim subjectCell As Range

    Dim searchFolderName As String

    ' Start outlook if it isn't opened (credits: https://stackoverflow.com/questions/33328314/how-to-open-outlook-with-vba)
    On Error Resume Next
    Set testOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0

    If testOutlook Is Nothing Then
        Shell ("OUTLOOK")
    End If

    ' Initialize Outlook class
    Set oOutlook = New clsOutlook

    ' Get the outlook inbox and sent items folders path (check the scope specification here: https://docs.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearch)
    searchFolderName = "'" & Outlook.Session.GetDefaultFolder(olFolderInbox).FolderPath & "','" & Outlook.Session.GetDefaultFolder(olFolderSentMail).FolderPath & "'"

    ' Loop through excel cells with subjects
    Set searchRange = ThisWorkbook.Worksheets("Sheet1").Range("A2:A4")

    For Each subjectCell In searchRange

        ' Only to cells with actual subjects
        If subjectCell.Value <> vbNullString Then

            Call oOutlook.SearchAndReply(subjectCell.Value, searchFolderName, False)

        End If

    Next subjectCell

    MsgBox "Search and reply completed"

    ' Clean object
    Set testOutlook = Nothing

End Sub

Затем добавьте модуль класса и назовите его: clsOutlook

В модуль класса добавьте следующий код:

Option Explicit

' Credits: Based on this answer: https://stackoverflow.com/questions/31909315/advanced-search-complete-event-not-firing-in-vba

' Event handler for outlook
Dim WithEvents OutlookApp As Outlook.Application
Dim outlookSearch As Outlook.Search
Dim outlookResults As Outlook.Results

Dim searchComplete As Boolean


' Handler for Advanced search complete
Private Sub outlookApp_AdvancedSearchComplete(ByVal SearchObject As Search)
    'MsgBox "The AdvancedSearchComplete Event fired."
    searchComplete = True
End Sub


Sub SearchAndReply(emailSubject As String, searchFolderName As String, searchSubFolders As Boolean)

    ' Declare objects variables
    Dim customMailItem As Outlook.MailItem
    Dim searchString As String
    Dim resultItem As Integer

    ' Variable defined at the class level
    Set OutlookApp = New Outlook.Application

    ' Variable defined at the class level (modified by outlookApp_AdvancedSearchComplete when search is completed)
    searchComplete = False

    ' You can look up on the internet for urn:schemas strings to make custom searches
    searchString = "urn:schemas:httpmail:subject like '" & emailSubject & "'" ' Use: subject like '%" & emailSubject & "%'" if you want to include words see %

    ' Perform advanced search
    Set outlookSearch = OutlookApp.AdvancedSearch(searchFolderName, searchString, searchSubFolders, "SearchTag")

    ' Wait until search is complete based on outlookApp_AdvancedSearchComplete event
    While searchComplete = False
        DoEvents
    Wend

    ' Get the results
    Set outlookResults = outlookSearch.Results

    If outlookResults.Count = 0 Then Exit Sub

    ' Sort descending so you get the latest
    outlookResults.Sort "[SentOn]", True

    ' Reply only to the latest one
    resultItem = 1

    ' Some properties you can check from the email item for debugging purposes
    On Error Resume Next
    Debug.Print outlookResults.Item(resultItem).SentOn, outlookResults.Item(resultItem).ReceivedTime, outlookResults.Item(resultItem).SenderName, outlookResults.Item(resultItem).Subject
    On Error GoTo 0

    Set customMailItem = outlookResults.Item(resultItem).ReplyAll

    ' At least one reply setting is required in order to replyall to fire
    customMailItem.Body = "Just a reply text " & customMailItem.Body

    customMailItem.Display

End Sub