Consulting

Results 1 to 9 of 9

Thread: search and send email from outlook using macro from excel

  1. #1

    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

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

    Pleaseeeeeeeeeeeeeee.

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

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

    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.

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    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.

  6. #6
    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?
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  7. #7
    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.

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

    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  9. #9
    Thanks a lot for all your help Graham...


Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •