We value your feedback.
Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!
Sub RecipientReport() Const xlWorkbookDefault = 51 Dim olkMessage As Outlook.MailItem, _ olkRecipient As Outlook.Recipient, _ excApp As Object, _ excBook As Object, _ excSheet As Object, _ lngRow As Long Set excApp = CreateObject("Excel.Application") Set excBook = excApp.Workbooks.Add() Set excSheet = excBook.Worksheets(1) excApp.Visible = True With excSheet .Cells(1, 1) = "Subject" .Cells(1, 2) = "To" .Cells(1, 3) = "Delivered" .Cells(1, 4) = "Read" End With lngRow = 2 For Each olkMessage In Application.ActiveExplorer.Selection excSheet.Cells(lngRow, 1) = olkMessage.Subject For Each olkRecipient In olkMessage.Recipients With olkRecipient excSheet.Cells(lngRow, 2) = olkRecipient.Address Select Case .TrackingStatus Case olTrackingDelivered excSheet.Cells(lngRow, 3) = olkRecipient.TrackingStatusTime Case olTrackingNotDelivered Case olTrackingRead excSheet.Cells(lngRow, 4) = olkRecipient.TrackingStatusTime Case olTrackingNotRead Case olTrackingNone End Select End With lngRow = lngRow + 1 Next Next Set excSheet = Nothing 'Change the file name and path on the next line' excBook.SaveAs "C:\eeTesting\Message Tracking.xlsx", xlWorkbookDefault excBook.Close True Set excBook = Nothing Set excApp = Nothing Set olkRecipient = Nothing Set olkMessage = Nothing MsgBox "Done", vbInformation + vbOKOnly, "Recipient Report" End Sub
Add your voice to the tech community where 5M+ people just like you are talking about what matters.
Join the community of 500,000 technology professionals and ask your questions.