• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Reply to all for a particular e-mail

ThrottleWorks

Excel Ninja
Hi,

I am using below mentioned to code to get latest e-mail.
I am able to get latest e-mail but not able to do a ‘reply to all’ for the particular e-mail.
I am able to ‘Display’ it.


How do I do ‘Reply to all’ for the particular e-mail in the loop.
Please note, rest of the code is working fine, the only issue I am facing is, doing a ‘reply to all’.

Can anyone please help me in this.

Code:
Public objWordApp As Word.Application
Option Explicit
'https://stackoverflow.com/questions/51655911/export-outlook-email-as-pdf
Sub Get_Latest_Email()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = "Please wait, macro in progess !"
    Dim MyOutlook As Outlook.Application
    Dim wrdApp As Word.Application
    Dim FSO As Object, TmpFolder As Object
    Dim sName As String
    Dim ONS As Outlook.Namespace
    Dim MYFOLD As Outlook.Folder
    Dim OMAIL As Object
    Dim R As Long
    Dim ListSht As Worksheet
    Dim WshShell As Object
    Dim SpecialPath As String
    Dim strToSaveAs As String
    Dim J As Variant
    Dim TmpFileName As Variant
    Dim MyDocs As Variant
    Dim MapSht As Worksheet
    Dim TempLr As Long
    Dim MyFileName As String
    Dim MyCount As Long
    Dim TempRng As Range
    Dim ConRng As Range
    Dim CRng As Range
    Dim DateRng As Range
    Dim DRng As Range
    Dim FirstRow As Long
    Dim objMail As Outlook.MailItem
    Dim strFileName As String
    Set MapSht = ThisWorkbook.Worksheets("Mapping")
    MapSht.Range("C2:BZ65000").ClearContents
    MapSht.Range("N1:O1").ClearContents
    On Error Resume Next
    Set MyOutlook = New Outlook.Application
    Set ONS = MyOutlook.GetNamespace("MAPI")
    Set ONS = MyOutlook.PickFolder
    Set MYFOLD = ONS.PickFolder
    If MYFOLD = "" Then
        ThisWorkbook.Activate
        MsgBox "Please select Outlook folder", vbCritical
        End
    End If
    Set OMAIL = MyOutlook.CreateItem(olMailItem)
    Set ListSht = ThisWorkbook.Worksheets("List")
    For Each OMAIL In MYFOLD.Items
        MyCount = MyCount + 1
        TempLr = MapSht.Cells(MapSht.Rows.Count, 3).End(xlUp).Row + 1
        MapSht.Cells(TempLr, 3).Value = TempLr - 1
        MapSht.Cells(TempLr, 4).Value = OMAIL.Subject
        MapSht.Cells(TempLr, 5) = OMAIL.ConversationID 'E Conversation ID
        MapSht.Cells(TempLr, 6) = OMAIL.ConversationTopic 'F Conversation Topic
        MapSht.Cells(TempLr, 7) = OMAIL.ReceivedTime 'G Received Time
        MapSht.Cells(TempLr, 8) = OMAIL.To 'H To
        MapSht.Cells(TempLr, 9) = OMAIL.Sender 'I From
        MapSht.Cells(TempLr, 10) = Now 'J Run time
        MapSht.Cells(TempLr, 12) = "=DATE(YEAR(RC[-5]),MONTH(RC[-5]),DAY(RC[-5]))" 'Date
        MapSht.Cells(TempLr, 12).Value = MapSht.Cells(TempLr, 12).Value
        On Error Resume Next
        Set objMail = OMAIL
        strFileName = Replace(objMail.Subject, "/", " ")
        strFileName = Replace(strFileName, "\", " ")
        strFileName = Replace(strFileName, ":", "")
        strFileName = Replace(strFileName, "?", " ")
        strFileName = Replace(strFileName, Chr(34), " ")
        strFileName = Replace(strFileName, ".xlsm", "_XLSM")
    Next OMAIL
    MyCount = 0
    MapSht.Sort.SortFields.Clear
    MapSht.Sort.SortFields.Add Key:=Range("G2:G65000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With MapSht.Sort
        .SetRange Range("C1:L65000")
        .Header = xlYes
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    TempLr = MapSht.Cells(MapSht.Rows.Count, 3).End(xlUp).Row
    MapSht.Range("E2:E" & TempLr).Copy
    MapSht.Range("Q2").PasteSpecial xlPasteValues
    MapSht.Range("Q1:Q65000").RemoveDuplicates Columns:=1, Header:=xlYes
    TempLr = MapSht.Cells(MapSht.Rows.Count, 3).End(xlUp).Row
    Set TempRng = MapSht.Range(MapSht.Cells(1, 3), MapSht.Cells(TempLr, 12))
    TempLr = MapSht.Cells(MapSht.Rows.Count, 17).End(xlUp).Row 'Q = Conversation ID
    Set ConRng = MapSht.Range(MapSht.Cells(2, 17), MapSht.Cells(TempLr, 17))
    MapSht.AutoFilterMode = False
    For Each CRng In ConRng
        MapSht.AutoFilterMode = False
        TempRng.AutoFilter Field:=3, Criteria1:="=" & CRng, Operator:=xlAnd
        FirstRow = 0
        FirstRow = MapSht.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells().Row
        MapSht.Cells(FirstRow, 13) = "Export"
        MapSht.AutoFilterMode = False
        FirstRow = 0
    Next CRng
    TempLr = MapSht.Cells(MapSht.Rows.Count, 3).End(xlUp).Row
    Set TempRng = MapSht.Range(MapSht.Cells(1, 3), MapSht.Cells(TempLr, 13)) 'M
    MyCount = 0
    For Each OMAIL In MYFOLD.Items
        MapSht.AutoFilterMode = False
        On Error Resume Next
        Set objMail = OMAIL
        strFileName = Replace(objMail.Subject, "/", " ")
        strFileName = Replace(strFileName, "\", " ")
        strFileName = Replace(strFileName, ":", "")
        strFileName = Replace(strFileName, "?", " ")
        strFileName = Replace(strFileName, Chr(34), " ")
        strFileName = Replace(strFileName, ".xlsm", "_XLSM")
        MyCount = MyCount + 1
        TempRng.AutoFilter Field:=3, Criteria1:="=" & OMAIL.ConversationID, Operator:=xlAnd
        TempLr = MapSht.Cells(MapSht.Rows.Count, 3).End(xlUp).Row
        If TempLr > 1 Then
            FirstRow = MapSht.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells().Row
            If MapSht.Cells(FirstRow, 13) = "Export" Then
                MapSht.Range("N1") = OMAIL.ReceivedTime
                MapSht.Range("O1") = MapSht.Cells(FirstRow, 7)
                If MapSht.Range("O1") = MapSht.Range("N1") Then
                    MapSht.Cells(FirstRow, 13) = "Done"
                    'Reply to all
                    OMAIL.Display
                    OMAIL.Reply
                    OMAIL.Display
                    OMAIL.Save
                End If
            End If
            MapSht.AutoFilterMode = False
        End If
        FirstRow = 0
        MapSht.AutoFilterMode = False
    Next OMAIL
    MyCount = 0
    ThisWorkbook.Activate
    ThisWorkbook.Worksheets("MainPage").Select
    Range("A1").Select
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    MsgBox "Done!"
End Sub
 
Top