VBA to search and reply in Outlook with specific criteria - excel

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:
The code search for the exact name, while i need to search for any email contain the word which in active cell.
The code search only in sent emails, while i need to search in both inbox and sent.
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