How to add VBA code to get data from outlook data with reference of any particular date and time?

[Himanshu1060]

Code is working well but i want to get data with reference of any particular date and time.
As i am new to vba couldn't able to make. Kindly help.

>>> use code - tags <<<

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