1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. 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...

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

Discussion in 'VBA Macros' started by ThrottleWorks, Feb 21, 2019.

  1. ThrottleWorks

    ThrottleWorks Excel Ninja

    Messages:
    1,956
    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 (vb):

    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
     
  2. ThrottleWorks

    ThrottleWorks Excel Ninja

    Messages:
    1,956
    Hi,

    It is done now. Thanks.

    Used, set OMAIL = OMAIL.ReplyAll

Share This Page