Hi,
I am working on a code to retrieve emails onto excel and then check if they have been responded and if so, how long did it take to respond. This is business requirement and hence help would be much appreciated. So far, I have code that retrieves all emails that have been responded and the time it took. But I also need the ones that have not been responded too to follow up and get it responded. I am copyin the code below for reference. main points that need attention 1. All emails should be listed whether or not responded for. 2. Sender email address should reflect email ID of the users rather than some wierd exchange server ID ( If you run this macro u will understand what am talking about ) 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" ' Locates best matching reply in related conversation to the given mail message passed in as oMailItem Private Function GetReply(oMailItem As MailItem) As MailItem 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 = oMailItem.GetConversation ' Let Outlook and Exchange do the hard lifting to get entire converstion for email being checked. OriginatorID = oMailItem.PropertyAccessor.BinaryToString(oMailItem.PropertyAccessor.GetProperty(PR_RECEIVED_BY_ENTRYID)) If Not conItem Is Nothing Then ' we have a conversation in which we should be able to match the reply Set ConTable = conItem.GetTable ConArray = ConTable.GetArray(ConTable.GetRowCount) LastVerb = oMailItem.PropertyAccessor.GetProperty(PR_LAST_VERB_EXECUTED) Select Case LastVerb Case EXCHIVERB_REPLYTOSENDER, EXCHIVERB_REPLYTOALL ', EXCHIVERB_FORWARD ' not interested in forwarded messages VerbTime = oMailItem.PropertyAccessor.GetProperty(PR_LAST_VERB_EXECUTION_TIME) VerbTime = oMailItem.PropertyAccessor.UTCToLocalTime(VerbTime) ' convert to local time ' Debug.Print "Reply to " & oMailItem.Subject & " sent on (local time): " & VerbTime For lp = 0 To UBound(ConArray) If ConArray(lp, 4) = "IPM.Note" Then ' it is a mailitem Set MsgItem = ns.GetItemFromID(ConArray(lp, 0)) 'mail item to check against 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 ' Allow for a clock drift of up to 300 seconds. This may be overgenerous Set GetReply = MsgItem Exit For ' only interested in first matching reply End If End If End If End If Next Case Else End Select End If ' as we exit function GetMsg is either Nothing or the reply we are interested in End Function Public Sub ListIt() Dim myOlApp As New Outlook.Application Dim myItem As Object ' item may not necessarily be a mailitem Dim myReplyItem As Outlook.MailItem Dim myFolder As Folder Dim xlRow As Long Set ns = myOlApp.GetNamespace("MAPI") ' Initialise Outlook access Set myFolder = ns.PickFolder() ' for the sake of this example we just pick a folder. InitSheet ActiveSheet ' initialise the spreadsheet xlRow = 3 For Each myItem In myFolder.Items If myItem.Class = olMail Then Set myReplyItem = GetReply(myItem) ' this example only deals with mailitems If Not myReplyItem Is Nothing Then ' we found a reply PopulateSheet ActiveSheet, myItem, myReplyItem, xlRow xlRow = xlRow + 1 End If End If DoEvents ' cheap and nasty way to allow other things to happen Next MsgBox "Done" End Sub Private Sub InitSheet(mySheet As Worksheet) With mySheet .Cells.Clear .Cells(1, 1).FormulaR1C1 = "Received" .Cells(2, 1).FormulaR1C1 = "From" .Cells(2, 2).FormulaR1C1 = "Subject" .Cells(2, 3).FormulaR1C1 = "Date/Time" .Cells(1, 4).FormulaR1C1 = "Replied" .Cells(2, 4).FormulaR1C1 = "From" .Cells(2, 5).FormulaR1C1 = "To" .Cells(2, 6).FormulaR1C1 = "Subject" .Cells(2, 7).FormulaR1C1 = "Date/Time" .Cells(2, 8).FormulaR1C1 = "Response Time" End With End Sub Private Sub PopulateSheet(mySheet As Worksheet, myItem As MailItem, myReplyItem As MailItem, xlRow As Long) Dim recips() As String Dim myRecipient As Outlook.Recipient Dim lp As Long With mySheet .Cells(xlRow, 1).FormulaR1C1 = myItem.SenderEmailAddress .Cells(xlRow, 2).FormulaR1C1 = myItem.Subject .Cells(xlRow, 3).FormulaR1C1 = myItem.ReceivedTime '.Cells(xlRow, 4).FormulaR1C1 = myReplyItem.SenderEmailAddress .Cells(xlRow, 4).FormulaR1C1 = myReplyItem.Sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS) ' I prefer to see the 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, 5).FormulaR1C1 = Join(recips, vbCrLf) .Cells(xlRow, 6).FormulaR1C1 = myReplyItem.Subject .Cells(xlRow, 7).FormulaR1C1 = myReplyItem.SentOn .Cells(xlRow, 8).FormulaR1C1 = "=RC[-1]-RC[-5]" .Cells(xlRow, 8).NumberFormat = "[h]:mm:ss" End With End Sub -- Are you =EXP(E:RT) or =NOT(EXP(E:RT)) in Excel? And do you wanna be? It’s =TIME(2,DO:IT,N:OW) ! Join official Facebook page of this forum @ https://www.facebook.com/discussexcel FORUM RULES 1) Use concise, accurate thread titles. Poor thread titles, like Please Help, Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get quick attention or may not be answered. 2) Don't post a question in the thread of another member. 3) Don't post questions regarding breaking or bypassing any security measure. 4) Acknowledge the responses you receive, good or bad. 5) Jobs posting is not allowed. 6) Sharing copyrighted material and their links is not allowed. NOTE : Don't ever post confidential data in a workbook. Forum owners and members are not responsible for any loss. --- You received this message because you are subscribed to the Google Groups "MS EXCEL AND VBA MACROS" group. To unsubscribe from this group and stop receiving emails from it, send an email to excel-macros+unsubscr...@googlegroups.com. To post to this group, send email to excel-macros@googlegroups.com. Visit this group at https://groups.google.com/group/excel-macros. For more options, visit https://groups.google.com/d/optout.