VBA для поиска и ответа в Outlook с указанными c критериями

Question

Я использую windows 10, Excel 2013 и Outlook 2013

Я новичок в Macro. Мне нужен макрос для выполнения ниже Задача:

1) В Excel я хочу открыть Outlook, если Outlook закрыт, и переместить Point.2, если Outlook уже открыт, затем перейти к Point.2

2) Поиск определенного c электронного письма в outlook во всех папках и подпапках с критериями «A» и «B»

a) Последнее полученное или отправленное электронное письмо с датой.

b) С указанием c Тема содержит «Одобрено», это должно быть взято из активной ячейки.

3) Откройте найденную последнюю почту в соответствии с вышеуказанными критериями: « Ответить всем ».

4) Написать комментарий и отобразить письмо или отправить.

Ниже код был моим началом, но он имеет следующие проблемы:

1. Код поиска точного имени, в то время как мне нужно найти любое электронное письмо, содержащее слово, которое в активной ячейке.

2. Код поиска только в отправленных письмах, а мне нужно для поиска во входящих и отправленных.

3. Код просто откройте письмо, мне нужно написать Это также шаблонный комментарий.

Большое спасибо заранее.

Sub ReplyMail_No_Movements()

  ' Outlook's constant
  Const olFolderSentMail = 5

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

  ' 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

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

  ' Main
  With OutlookApp.Session.GetDefaultFolder(olFolderSentMail).Items.Restrict(sFilter)
    If .Count > 0 Then
      .Sort "ReceivedTime", True
      With .Item(1).replyall
        .Display
        '.Send
      End With
    Else
      MsgBox "No emails found with Subject:" & vbLf & "'" & sSubject & "'"
    End If
  End With

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

End Sub

Answer 1

Кажется, работа сейчас:

Sub ReplyAllLastEmailFromInboxAndSent()

    Dim olApp As Outlook.Application
    Dim olNs As Namespace
    Dim Fldr As MAPIFolder
    Dim objMail As Object
    Dim objReplyToThisMail As MailItem
    Dim lngCount As Long
    Dim objConversation As Conversation
    Dim objTable As Table
    Dim objVar As Variant
    Dim strBody As String
    Dim searchFolderName As String

    Set olApp = Session.Application
    Set olNs = olApp.GetNamespace("MAPI")
   Set Fldr = olNs.GetDefaultFolder(olFolderSentMail)

    searchFolderName = "'" & Outlook.Session.GetDefaultFolder(olFolderInbox).FolderPath & "','" & Outlook.Session.GetDefaultFolder(olFolderSentMail).FolderPath & "'"


    lngCount = 1

    For Each objMail In Fldr.Items
        If TypeName(objMail) = "MailItem" Then
            If InStr(objMail.Subject, ActiveCell.Value) <> 0 Then
                Set objConversation = objMail.GetConversation
                Set objTable = objConversation.GetTable
                objVar = objTable.GetArray(objTable.GetRowCount)
                Set objReplyToThisMail = olApp.Session.GetItemFromID(objVar(UBound(objVar), 0))
                With objReplyToThisMail.replyall
                    strBody = "Dear " & "<br>" & _
                                "<p>Following up with the below. May you please advise?" & _
                                "<p>Thank you," & vbCrLf
                    .HTMLBody = strBody & .HTMLBody
                    .Display
                End With
                Exit For
            End If
        End If
    Next objMail

    Set olApp = Nothing
    Set olNs = Nothing
    Set Fldr = Nothing
    Set objMail = Nothing
    Set objReplyToThisMail = Nothing
    lngCount = Empty
    Set objConversation = Nothing
    Set objTable = Nothing
    If IsArray(objVar) Then Erase objVar

End Sub