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.

Reply via email to