Option Explicit Public ns As Outlook.Namespace Private Const EXCHIVERB_REPLYTOSENDER = 102 Private Const EXCHIVERB_REPLYTOALL = 103 Private Const EXCHIVERB_FORWARD = 104 Private Const PR_LAST_VERB_EXECUTED = "http://schemas.microsoft.com/mapi/proptag/0x10810003" Private Const PR_LAST_VERB_EXECUTION_TIME = "http://schemas.microsoft.com/mapi/proptag/0x10820040" Private Const PR_SMTP_ADDRESS = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E" Private Const PR_RECEIVED_BY_ENTRYID As String = "http://schemas.microsoft.com/mapi/proptag/0x003F0102" Private Function GetReply(olMailItem As MailItem) As MailItem 'On Error Resume Next Dim conItem As Outlook.Conversation Dim ConTable As Outlook.Table Dim ConArray() As Variant Dim MsgItem As MailItem Dim lp As Long Dim LastVerb As Long Dim VerbTime As Date Dim Clockdrift As Long Dim OriginatorID As String Set conItem = olMailItem.GetConversation OriginatorID = olMailItem.PropertyAccessor.BinaryToString(olMailItem.PropertyAccessor.GetProperty(PR_RECEIVED_BY_ENTRYID)) If Not conItem Is Nothing Then Set ConTable = conItem.GetTable ConArray = ConTable.GetArray(ConTable.GetRowCount) LastVerb = olMailItem.PropertyAccessor.GetProperty(PR_LAST_VERB_EXECUTED) Select Case LastVerb Case EXCHIVERB_REPLYTOSENDER, EXCHIVERB_REPLYTOALL, EXCHIVERB_FORWARD VerbTime = olMailItem.PropertyAccessor.GetProperty(PR_LAST_VERB_EXECUTION_TIME) VerbTime = olMailItem.PropertyAccessor.UTCToLocalTime(VerbTime) Debug.Print "Reply to " & olMailItem.Subject & " sent on (local time): " & VerbTime For lp = 0 To UBound(ConArray) If ConArray(lp, 4) = "IPM.Note" Then Set MsgItem = ns.GetItemFromID(ConArray(lp, 0)) If Not MsgItem.Sender Is Nothing Then If OriginatorID = MsgItem.Sender.ID Then Clockdrift = DateDiff("s", VerbTime, MsgItem.SentOn) If Clockdrift >= 0 And Clockdrift < 300 Then Set GetReply = MsgItem Exit For End If End If End If End If Next Case Else End Select End If End Function Public Sub ListIt() Dim myOlApp As New Outlook.Application Dim myItem As Object Dim myReplyItem As Outlook.MailItem Dim MyFolder As Folder Dim xlRow As Long 'Application.ScreenUpdating = False Set ns = Outlook.GetNamespace("MAPI") 'Set ns = myOlApp.GetNamespace("MAPI") 'Set MyFolder = ns.GetDefaultFolder(olFolderInbox) Set MyFolder = ns.PickFolder xlRow = 3 For Each myItem In MyFolder.Items If myItem.Class = olMail Then Set myReplyItem = GetReply(myItem) If Not myReplyItem Is Nothing Then PopulateSheet ActiveSheet, myItem, myReplyItem, xlRow xlRow = xlRow + 1 Else: PopulateSheet ActiveSheet, myItem, myReplyItem, xlRow xlRow = xlRow + 1 End If End If DoEvents Next 'Application.ScreenUpdating = True 'MsgBox "Done" End Sub Private Sub PopulateSheet(mySheet As Worksheet, myItem As MailItem, myReplyItem As MailItem, xlRow As Long) 'On Error Resume Next Dim recips() As String Dim Recipients As Outlook.Recipient Dim lp As Long With mySheet .Cells(xlRow, 1).FormulaR1C1 = myItem.Sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS) .Cells(xlRow, 2).FormulaR1C1 = myItem.Subject .Cells(xlRow, 3).FormulaR1C1 = myItem.ReceivedTime .Cells(xlRow, 4).FormulaR1C1 = myItem.Categories .Cells(xlRow, 5).FormulaR1C1 = myReplyItem.Sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS) For lp = 0 To myReplyItem.Recipients.Count - 1 ReDim Preserve recips(lp) As String recips(lp) = myReplyItem.Recipients(lp + 1).Address Next .Cells(xlRow, 6).FormulaR1C1 = myReplyItem.To .Cells(xlRow, 7).FormulaR1C1 = myReplyItem.CC .Cells(xlRow, 8).FormulaR1C1 = myReplyItem.Subject .Cells(xlRow, 9).FormulaR1C1 = myReplyItem.SentOn If .Cells(xlRow, 5).Value = "" Then .Cells(xlRow, 11).FormulaR1C1 = "=Now()-RC[-8]" .Cells(xlRow, 11).NumberFormat = "[h]:mm:ss" Else .Cells(xlRow, 10).FormulaR1C1 = "=RC[-1]-RC[-7]" .Cells(xlRow, 10).NumberFormat = "[h]:mm:ss" End If End With End Sub Sub FolderPicker() Dim objNS As Namespace Dim objFolder As Folder Dim MyWb As Workbook Set MyWb = ActiveWorkbook 'Set Outlook Object Set objNS = Outlook.GetNamespace("MAPI") Set objFolder = objNS.PickFolder End Sub Public Sub PickOutlookFolder() 'Microsoft Outlook XX.X Object Library is required to run this code 'Variable declaration Dim objNS As Namespace Dim objFolder As Folder Dim strFolderPath As String Dim strEntryID As String Dim strPick As String 'Set Outlook Object Set objNS = Outlook.GetNamespace("MAPI") Set objFolder = objNS.PickFolder AppActivate Application.Caption If TypeName(objFolder) <> "Nothing" Then strFolderPath = objFolder.FolderPath strEntryID = objFolder.EntryID strPick = objFolder.Name End If 'Show the selected folder details on Excel sheet Sheet1.Range("B6").Value = strFolderPath Sheet1.Range("C6").Value = strEntryID Sheet1.Range("C7").Value = strPick 'Close the objects Set objFolder = Nothing Set objNS = Nothing MsgBox ("Done") End Sub