How to "link" a read reciept with the sent email?

dcharland

New Member
Joined
Mar 2, 2011
Messages
40
My excel spreadsheet send the same email to multiple people from a list of email addresses in the spread sheet. In order to enable tracking I'm requesting a read receipt.

The problem:
I can't extract the email address from the sender of the read receipt and therefore can't update the status of the email in my spreadsheet.

I need help with:
If the item is not an email, then find the corresponding email in the "sent" folder. Then take the email address from the "To" line (of the sent email).

Thanks for any help you can offer.
 

Some videos you may like

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.

DauntingGecko

Well-known Member
Joined
Feb 2, 2006
Messages
521
I get entirely what your saying but you could be massively over complicating it. If it's a one off then it would be easier to set up an email rule so read receipts end up in a certain folder. Whats the purpose of the read receipt? Could you put a voting button on your email asking for users to confirm they've read it? All your responses will then be in Outlook.

It can be done, but the Excel route will be very long winded for something that probably isn't going to be used a lot (apologies as I don't know if it will or not). I'm not saying it can't be done (it can), however it may not be the best way to do your task; it will require a substancial amount of code to do it this way - maybe think outside the box beyond Excel? :)
 

dcharland

New Member
Joined
Mar 2, 2011
Messages
40
Hi DauntingGecko,

The purpose of the spreadsheet is to send "information meeting" request with Job hunting in mind....but the spreadsheet can have various usages. So, I would think that it wouldn't be a one of. Furthermore, I would like to make the spreadsheet available on my website (for free) after I have it working properly.

I already have all of the code working (send email), update status (if not read receipt or other like read, undeliverable, ect...) This is the last "bump" in the road (or at least I'm hoping it is :), at least for a Big one)

Having the "status" directly updated into the spreadsheet allows the user's to track the status of each emails, there could be over 100 of them) Currently I personally sent 467) tracking those manually isn't doable.

Here is the code I have so far for the setting the status.

HTML:
Sub SetStatus()
 
  
Dim temparray() As Variant
Dim Myemailarray() As Variant
Dim mea As Integer
Dim es As Integer
Dim OutApp As Object ' Outlook.Application
Dim NmSpace As Object 'Outlook.NameSpace
Dim Inbox As Object ' Outlook.MAPIFolder
Dim MItem As Object 'Outlook.MailItem
'Dim MItem As Outlook.MailItem



Dim MySubFolder As Object
Dim i As Long
Dim Response As String
Dim BodyArray() As Variant
Dim EmailAddress As String
Dim Ebody As Variant
Dim Ewords As Variant
Dim Status As String
Dim Cell As Range
Dim ProcessedFolder As Object
Dim MatchFound As String
Dim countnoemail As Integer
Dim emaillist As Variant
Dim sender As Variant
Dim el As Integer
Dim j As Integer
Dim t As String


Set OutApp = CreateObject("Outlook.Application")
Set NmSpace = OutApp.GetNamespace("MAPI")
Set Inbox = NmSpace.GetDefaultFolder(6) 'olFolderInbox
Set MySubFolder = Inbox.Folders("test") ' Note Case Sensitive!
Set ProcessedFolder = Inbox.Folders("processed") ' Note Case Sensitive!

emaillist = ""
el = 0
sender = ""

'****************************************************************
' This macro will look in the body of each email and extract
' the email addresses contained within them to cross reference
' them with the email addresses in excle and will set the status
' according to the subject email. March 4 2011
'****************************************************************

'MsgBox MySubFolder.Items.count ' Debugging Only
mea = 1
'MsgBox MItem.SenderEmailAddress 'email address from sender



For Each MItem In MySubFolder.Items ' Starts with first email recieved

'********** Just for Testing purpose *****************
If MItem.MessageClass = "IPM.Note" Then
    MsgBox "it's an email"
    MsgBox MItem.SenderEmailAddress
ElseIf InStr(MItem.MessageClass, "Report") Then
    MsgBox "it's a read receipt"
    MsgBox MItem.MessageClass
    MsgBox MItem.SenderEmailAddress
End If

'MItemm.Reply
'************* End of testing **************************


MItem.unread = "True" 'set the email as unread
'MsgBox MItem.Body
    Select Case True
        Case Left(MItem.Subject, 13) = "Undeliverable": Status = "Undeliverable"
        Case Left(MItem.Subject, 4) = "Read": Status = "Read"
        Case Left(MItem.Subject, 8) = "Not Read": Status = "Deleted"
        Case InStr(MItem.Subject, "(Failure)"): Status = "failed"
        Case InStr(MItem.Subject, "(Delay)"): Status = "Delayed"
        Case UCase(Left(MItem.Subject, 3)) = "RE:": Status = "Replied"
        Case InStr(MItem.Subject, 14) = "Returned mail:": Status = "Invalid Email"
        Case Else: Status = "Other"
    End Select
        
    ' Now I need to Find all of the email adresses within the email and not include duplicated ones, If any.
     
     If InStr(MItem.Body, "@") Then ' If MItem.body contains an @ character
        'Assign each word in the body of the email to Ewords
        MItem.unread = "False"
        Ewords = Split(MItem.Body) ' Split each word in MItem.body and assign it to the Ewords variable
        
            For i = LBound(Ewords) To UBound(Ewords) ' sets the for i loop to the number of split in MItem
                If InStr(Ewords(i), "@") Then 'Found the string that contains an email address
                    'clean the email address
                    Call EmailAddresCleanup(Ewords(i))
                    ReDim Preserve temparray(2, mea)
                    'look into my array to see if the email is already there?
              
                    If temparray(LBound(temparray), LBound(temparray)) <> "" Then 'compare emails
                        For j = LBound(temparray, 2) To UBound(temparray, 2)
                            If temparray(1, j) = emailclean Then temparray(2, j) = Status: t = "true" 'update its status only
                        Next j
                     
                     End If
                        If t <> "true" Then ' No match was found so writing the new email and status
                        temparray(1, mea) = emailclean
                        temparray(2, mea) = Status
                        mea = mea + 1
                        
                     Else
                        t = ""
                        End If
                   
                Else
                ' No emails were found in the string, look at next string
                End If
                
            Next i 'Next String in body of email
            
     
     
     Else
    'MsgBox "No email in the body, need to find the code to grab it from the 'from'"
    ' on workaround would be to reply to the email and then read the "to" field
    ' Grab the email address from the sender
    On Error Resume Next
    'MsgBox MItem.senderemailaddress
    sender = MItem.SenderEmailAddress ' this is not working because the item is not an email it's a read reciept
    Dim k As Integer
    ReDim Preserve temparray(2, mea)
        For k = LBound(temparray, 2) To UBound(temparray, 2)
            If temparray(1, k) = sender Then temparray(2, k) = Status: t = "true" 'update its status only
        Next k
            If t <> "true" Then
                temparray(1, mea) = sender
                temparray(2, mea) = Status
                MItem.unread = "False"
                mea = mea + 1
                
            Else
            t = ""
            End If


     End If
   
   
'MItem.Move ProcessedFolder

Next MItem ' Goes to next email

Myemailarray = Application.Transpose(temparray)

'****************************************************************************
' Update excel with most recent status
'
'****************************************************************************
Dim x As Integer
x = 1
For x = LBound(Myemailarray, 1) To UBound(Myemailarray, 1)
    For Each Cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants) ' scroll thru the D column
    'MsgBox Cells(Cell.row, "J").Value
        If Myemailarray(x, 1) = Cells(Cell.row, "D").Value Then 'found the cell with the same email address
           Cells(Cell.row, "J").Value = Myemailarray(x, 2) 'update status
        Else
        End If
    Next ' Looking at the next cell
Next x




GoTo cleanup ' Cleans all of the variables

cleanup:

Set MItem = Nothing
Set Inbox = Nothing
Set NmSpace = Nothing
Set OutApp = Nothing
Set MySubFolder = Nothing
MsgBox "Done"
End Sub
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,109,028
Messages
5,526,332
Members
409,696
Latest member
EERS

This Week's Hot Topics

Top