search and send email from outlook using macro from excel

1 > I have this below code which searched for emails based on subject however I am able to search and it pops open but it does not reply.

2 > I have another code which emails to the selected people from an excel list with attachments.

Can some one please help me in joining these two codes so that i can search for email and reply (I need to send reminders having the old email as trail email)

Please help.


Sub TestMailTool() ' Is working in Office 2000-2007
Dim OutApp As Object
Dim OutNameSpace As Object
Dim OutFolder As Object
Dim OutItms As Object
Dim OutMail As Object
Dim i As Integer
Dim mail
Dim replyall As Object
'Dim strbody As String
'Dim MyTasks As Object
'Dim sir() As String
'Dim myitems As Outlook.Items
'Dim myitem As Object




Set OutApp = CreateObject("Outlook.Application")
'Set OutMail = OutApp.CreateItem(0)
Set OutNameSpace = OutApp.GetNamespace("MAPI")
Set OutFolder = OutNameSpace.GetDefaultFolder(6)
Set OutItms = OutFolder.Items
i = 1
'Set MyTasks = OutFolder.Items
'Set myitems = myInbox.Items


For Each OutMail In OutFolder.Items
If InStr(OutMail.Subject, "Hello 12345") <> 0 Then


OutMail.Display
OutMail.replyall
Body = "test reply" & vbCrLf & BR
i = i + 1
End If
Next OutMail
End Sub

************************

Sub Mail_Outlook()
Dim OutApp As Object
Dim OutMail As Object

lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

If Cells(lastrow, 1).Value <> "" Then

MailTo = Cells(lastrow, 1).Offset(0, 2).Value


'Send Mail
For i = 2 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(o)

With OutMail
.To = Cells(i, 1).Value
.CC = Cells(i, 2).Value
.BCC = ""
.Subject = "Hello 12345" & Cells(i, 4).Value
.Body = "Dear Sir / Madam,"
.Attachments.Add Cells(i, 6).Value
.Display

End With

Set OutMail = Nothing
Set OutApp = Nothing
Next

End If

End Sub

Can someone please help, I am in desperate need of a solution.

Pleaseeeeeeeeeeeeeee.

Not a single reply, is it too difficult what i am asking?

Not difficult really. It's just a matter of waiting for someone who knows the answer ... like me :hi:.

You need the code indicated at the top of the module to start Outlook correctly or the message body editing will not work -
I have not tested the first macro (but it looks OK), but the second one works, subject to valid data in the worksheet.

Code:

---

Option Explicit

'http://www.rondebruin.nl/win/s1/outlook/openclose.htm

Sub TestMailTool()
Dim OutApp As Object
Dim OutNameSpace As Object
Dim OutFolder As Object
Dim olItem As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
    Set OutApp = OutlookApp()
    Set OutNameSpace = OutApp.GetNamespace("MAPI")
    Set OutFolder = OutNameSpace.GetDefaultFolder(6)
    For Each olItem In OutFolder.Items
        If InStr(OutMail.Subject, "Hello 12345") > 0 Then
            Set OutMail = olItem.Reply
            With OutMail
                .replyall
                .BodyFormat = 2
                Set olInsp = .GetInspector
                Set wdDoc = olInsp.WordEditor
                Set oRng = wdDoc.Range
                .Display
                oRng.Text = "test reply" & vbCr
            End With
        End If
    Next olItem
End Sub

Sub Mail_Outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim LastRow As Long
Dim i As Long
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object

    LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    'If Cells(LastRow, 1).value <> "" Then
    'MailTo = Cells(LastRow, 1).Offset(0, 2).value
    'Send Mail
    Set OutApp = OutlookApp()
    For i = 2 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .BodyFormat = 2
            .To = ActiveSheet.Cells(i, 1).value
            .CC = ActiveSheet.Cells(i, 2).value
            .BCC = ""
            .Subject = "Hello 12345 " & ActiveSheet.Cells(i, 4).value
            .Attachments.Add ActiveSheet.Cells(i, 6).value
            .Display
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range
            oRng.Text = "Dear Sir / Madam," & vbCr
        End With
        DoEvents
    Next i
    'End If
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing

End Sub

---

To CC Subject Body Attachment Subject to be searched example1emailadd Supervisoremailid Reminder 1 Immediate effect Hello 12345 example2emailadd Supervisoremailid Reminder 2 Please revret RE: FUN Friday on Friday

Hi Graham ,

Sorry for the late reply, was not well hence could not work all these months. But back to work and desperately need your help.

The above is an example of excel that I have. I tried yours but somehow its not working.

Issues faced are :-
1> the original email content is missing, so it displays a new email but not the old email content.
2> it does not contain original email sender and all others in CC, it picks up "To" and "CC" from excel.

What i exactly want is , it should search subject from column "F" and reply along with additional details from column A, B, C, D, E. what should I do if I have different subjects every time, changing subject in code is tedious and hence I would request you to help me so that it loops until the last line of column F that is the subject line.

I would be highly obliged if you could please help me in this.

Thanking you in Advance and once again sorry for the inconvenience.

Sorry to hear that you have been unwell. I am all too familiar with that. However it is not exactly clear what it is that you expect to happen.
There are two macros I based on your originals. One sends a reply to any message in the folder that contains "Hello 12345" in the subject. The other creates a new message for each entry in the worksheet without reference to existing message. From your recent post I suspect that you want a macro that somehow combines the two?
Can you confirm you are wanting to look through the folder for each matching subject in the worksheet and send a reply to that e-mail using the values in the worksheet?

Yes that's what I am exactly looking for.

It should search from all folders in outlook and reply to that email with the old content of email below and above it the content in the excel sheet.

For instance I have a list of subjects in excel so it should search each subject from the column and reply.

Thank you for all your help.

Maybe the following will work for you. It will prompt to select the folder to process.

Code:

---

Option Explicit

'Graham Mayor - https://www.gmayor.com - Last updated - 04 Feb 2019
'Requires the code from
'http://www.rondebruin.nl/win/s1/outlook/openclose.htm

Sub ReplyToMail()
Dim OutApp As Object
Dim OutNameSpace As Object
Dim OutFolder As Object
Dim olItem As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim lngRow As Long
    Set OutApp = OutlookApp()
    Set OutNameSpace = OutApp.GetNamespace("MAPI")
    On Error Resume Next
    Set OutFolder = OutNameSpace.pickfolder
    If Err.Number > 0 Then GoTo lbl_Exit
    For Each olItem In OutFolder.Items
        For lngRow = 2 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
            If InStr(olItem.Subject, ActiveSheet.Cells(lngRow, 6)) > 0 Then
                Set OutMail = olItem.Reply
                With OutMail
                    .BodyFormat = 2
                    .To = ActiveSheet.Cells(lngRow, 1).value
                    .CC = ActiveSheet.Cells(lngRow, 2).value
                    .BCC = ""
                    .Subject = .Subject & " - " & ActiveSheet.Cells(lngRow, 3).value
                    .Attachments.Add ActiveSheet.Cells(lngRow, 6).value
                    .Display
                    Set olInsp = .GetInspector
                    Set wdDoc = olInsp.WordEditor
                    Set oRng = wdDoc.Range
                    oRng.collapse 1
                    oRng.Text = "Dear Sir / Madam," & vbCr & _
                                ActiveSheet.Cells(lngRow, 4).value
                    '.send
                End With
                Exit For
            End If
            DoEvents
        Next lngRow
        DoEvents
    Next olItem
lbl_Exit:
    Set OutNameSpace = Nothing
    Set OutMail = Nothing
    Set OutFolder = Nothing
    Set OutApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

---

Thanks a lot for all your help Graham...

:bow:

Hi Spanx, I am newbie to VBA I tried copy pasting the code in excel module but I am not able to run the macro, would be great if you can share the file or the full code. Thanks a million for your support and help.

Spanx has not visited this site since 2/11/2019.

See GMayor's posts above.

I have closed this thread. If you need more help, please start a new thread. You can post a link to this thread in you new thread.