VBA to search and reply in Outlook with specific criteria

Question

I am Using windows 10, Excel 2013 and Outlook 2013

I am new to Macro. I need macro to perform below Task:

1) From Excel I want to open Outlook if Outlook is closed and move Point.2, If outlook is already open then move to Point.2

2) Search for a specific email in outlook in all folders and sub folders with criteria “A” and “B”

a) Latest dated received or sent email.

b) With specific Subject contains “Approved”, this to be taken from active cell.

3) Open the found latest mail as per above criteria do “Reply all”.

4) Write a comment and display the mail or send.

Below code was my start, but it has the following issues:

1. The code search for the exact name, while i need to search for any email contain the word which in active cell.

2. The code search only in sent emails, while i need to search in both inbox and sent.

3. The code just open the email, i need to write template comment as well.

Many thanks in advance.

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

It seems work now:

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