HOWTO: Correlate Delivery and Read Receipt to the Original Message

• Collaboration Data Objects (CDO), version 1.21

SUMMARY

You can use the MAPI properties PR_SEARCH_KEY and PR_ORIGINAL_SEARCH_KEY to programmatically correlate the Delivery Receipt and/or the Read Receipt report-messages to the message that requested the Delivery or Read Receipt.

MORE INFORMATION

Using PR_SEARCH_KEY and PR_ORIGINAL_SEARCH_KEY can allow you to programmatically correlate a Delivery Receipt (DR) or Read Receipt (RR) reports with the message that prompted it's generation. There are some limitations to this technique:

• You must be using messaging system that supports DR and/or RR. If the mail system you are using does not support DR and/or RR then you will not be able to receive the DR/RR when the message is delivered and/or read.
• This example might not work if your original message is sent outside of your organization. This is because the PR_ORIGINAL_SEARCH_KEY is supported in messages of class REPORT.IPM.NOTE.DR (Delivery Receipt) and REPORT.IPM.NOTE.IPNRN (Read Receipt). Messages sent outside of your organization (even to other Microsoft Exchange messaging systems) may generate a DR/RR of a class IPM.Note, which does not support the PR_ORIGINAL_SEARCH_KEY.

Option Explicit
'Requires a reference to the Microsoft CDO 1.21 Library
Dim objSession As MAPI.Session

Private Sub Form_Load()
    Dim strServer As String     'Name of an Exchange Server
    Dim strMailbox As String    'Name of Mailbox
    
    Set objSession = New MAPI.Session
    strServer = "MyServer"
    strMailbox = "MyMailbox"
    objSession.Logon ShowDialog:=False, _
                     NewSession:=False, _
                     NoMail:=True, _
                     ProfileInfo:=strServer & vbLf & strMailbox
End Sub

Private Sub cmdProcessMail_Click()
    Dim objSentItemsFolder As Folder    'Location of original messages
    Dim objSentItems As Messages        'Collection of original messages
    Dim objSentItem As Message          'Original message
    Dim strSearchKey As String          'From message
    Screen.MousePointer = vbHourglass
    
    'Get a collection of the messages in your Sent Items folder. These are the
    'messages you will compare the DR/RR against.
    Set objSentItemsFolder = objSession.GetDefaultFolder(CdoDefaultFolderSentItems)
    Set objSentItems = objSentItemsFolder.Messages
    
    'Get the first message in the SentItems collection
    Set objSentItem = objSentItems.GetFirst
    
    'Set up a loop that runs through all the messages in the Sent Items folder
    'and calls a function that compares the CdoPR_SEARCH_KEY in the original
    'message to the CdoPR_ORIGINAL_SEARCH_KEY in the Receipt.
    Do
        'Set strSearchKey to CdoPR_SEARCH_KEY, which is the search key in
        'the original message
        strSearchKey = objSentItem.Fields(CdoPR_SEARCH_KEY)
        
        'Set up an If block that will call the bMatchDrRr function.
        'If the Match is found that means that the item was delivered
        'or read. Process the messages. This example shows moving the
        'original message from the "Sent Items" folder to the
        '"Confirmed Delivery" folder. If the item is matched then you need
        'to do a GetFirst in order to get the next item in the collection.
        'Otherwise, do a GetNext to move on to the next item.
        If bMatchDrRr(strSearchKey, objSentItem.Subject) Then
            objSentItem.MoveTo objSentItemsFolder.Folders("Confirmed Delivery").ID
            Set objSentItem = objSentItems.GetFirst
        Else
            Set objSentItem = objSentItems.GetNext
        End If
    Loop Until objSentItem Is Nothing
    
    Set objSentItem = Nothing
    Set objSentItems = Nothing
    Set objSentItemsFolder = Nothing
    Screen.MousePointer = vbNormal
End Sub

Private Function bMatchDrRr(strSearchString As String, _
                            strSentItemSubject As String) As Boolean
    Dim objInbox As Folder              'Location of DR/RR
    Dim objInboxMessages As Messages    'Collection of DR/RR
    Dim objInboxMessage As Message      'DR/RR
    Dim strOriginalSearchKey As String  'From DR/RR
    Dim objMsgFilter As MessageFilter
    
    On Error GoTo ErrorHandler

    bMatchDrRr = False  'initialize function to False
    
    'Get a collection of the messages in your Inbox. This will include
    'any Delivery/Read Receipts
    Set objInbox = objSession.Inbox
    Set objInboxMessages = objInbox.Messages
    
    'Set a filter on the Inbox messages. Filter for the PR_SEARCH_KEY
    'you got from cmdProcessMail_Click
    Set objMsgFilter = objInboxMessages.Filter
    objMsgFilter.Fields(CdoPR_ORIGINAL_SEARCH_KEY) = strSearchString
    
    Set objInboxMessage = objInboxMessages.GetFirst
    
    'If you have a match then the following line will work,
    'otherwise, it will fail and drop to the error handler.
    'Move the Delivery Receipt to another folder.
    objInboxMessage.MoveTo objInbox.Folders("Delivery Receipts").ID
    bMatchDrRr = True
    
    Set objInboxMessage = Nothing
    Set objInboxMessages = Nothing
    Set objInbox = Nothing
    Exit Function
    
ErrorHandler:
    'This ErrorHandler will just report that there was an error in the function.
    'You will probably want an ErrorHandler that is a little more intelligent.
    Debug.Print "Error encountered in bMatchDrRr while looking for match to " _
                & strSentItemSubject & vbLf & _
                "Error Number: " & Err.Number & vbLf & _
                "Description:  " & Err.Description & vbLf & _
                "Resuming with next comparison" & vbLf & _
                "*********************************************************" & vbLf
    bMatchDrRr = False
    Set objInboxMessage = Nothing
    Set objInboxMessages = Nothing
    Set objInbox = Nothing
End Function

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    On Error Resume Next
    objSession.Logoff
    Set objSession = Nothing
End Sub 

Additional query words:

Keywords : kbCDO kbCDO121 kbMsg kbVBp kbGrpMsg kbDSupport
Version : WINDOWS:1.21
Platform : WINDOWS
Issue type : kbhowto