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