How to identify emails where sender is also a recipient? - vba

Question

I'm trying to export sender email address and recipient email addresses (to and cc) to Excel. I adapted code I found online. It does most of what I need but there are two problems:
It only works with a single recipient. If there are two or more recipients, it provides names (e.g. Jo Bloggs) instead of email addresses.
It only includes people in the 'To' field, not those in the 'CC' field.
I think the bit that needs fixing is:
'trying to get recipient email address
Dim olEU2 As Outlook.ExchangeUser
Dim oEDL2 As Outlook.ExchangeDistributionList
Dim recip2 As Outlook.Recipient
Set recip2 = Application.Session.CreateRecipient(strColE)
Select Case recip2.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL2 = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
End Select
Full code:
Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim objOL As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Dim objItems As Outlook.Items
Dim obj As Object
Dim olItem 'As Outlook.MailItem
Dim strColA, strColB, strColC, strColD, strColE, strColF As String
' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\Book1.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
On Error Resume Next
' Open the workbook to input the data
' Create workbook if doesn't exist
Set xlWB = xlApp.Workbooks.Open(strPath)
If Err <> 0 Then
Set xlWB = xlApp.Workbooks.Add
xlWB.SaveAs FileName:=strPath
End If
On Error GoTo 0
Set xlSheet = xlWB.Sheets("Sheet1")
On Error Resume Next
' add the headers if not present
If xlSheet.Range("A1") = "" Then
xlSheet.Range("A1") = "Sender Name"
xlSheet.Range("B1") = "Sender Email"
xlSheet.Range("C1") = "Subject"
xlSheet.Range("D1") = "Body"
xlSheet.Range("E1") = "Sent To"
xlSheet.Range("F1") = "Date"
End If
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1
' get the values from outlook
Set objOL = Outlook.Application
Set objFolder = objOL.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
For Each obj In objItems
Set olItem = obj
'collect the fields
strColA = olItem.SenderName
strColB = olItem.SenderEmailAddress
strColC = olItem.Subject
strColD = olItem.Body
strColE = olItem.To
strColF = olItem.ReceivedTime
' Get the Exchange address
' if not using Exchange, this block can be removed
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.Session.CreateRecipient(strColB)
If InStr(1, strColB, "/") > 0 Then
' if exchange, get smtp address
Select Case recip.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
strColB = olEU.PrimarySmtpAddress
End If
End Select
End If
' End Exchange section
'trying to get recipient email address
Dim olEU2 As Outlook.ExchangeUser
Dim oEDL2 As Outlook.ExchangeDistributionList
Dim recip2 As Outlook.Recipient
Set recip2 = Application.Session.CreateRecipient(strColE)
Select Case recip2.AddressEntry.AddressEntryUserType
Case OlAddressEntryUserType.olExchangeUserAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU2 = recip.AddressEntry.GetExchangeUser
If Not (olEU2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL2 = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL2 Is Nothing) Then
strColE = olEU2.PrimarySmtpAddress
End If
End Select
'write them in the excel sheet
xlSheet.Range("A" & rCount) = strColA
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("c" & rCount) = strColC
xlSheet.Range("d" & rCount) = strColD
xlSheet.Range("e" & rCount) = strColE
xlSheet.Range("f" & rCount) = strColF
'Next row
rCount = rCount + 1
xlWB.Save
Next
' don't wrap lines
xlSheet.Rows.WrapText = False
xlWB.Save
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub

Answer 1

Iterating through all items in the folder is not really a good idea. I'd recommend starting from the Find/FindNext or Restrict methods instead. Please note that there are some item properties that you can’t use for the filter. You can read more about the properties not allowed in the filter string and string formats used for the search criterion on MSDN.
The following example uses the Restrict method to get all Inbox items of Business category and moves them to the Business folder. To run this example, create or make sure a subfolder called 'Business' exists under Inbox:
Sub MoveItems()
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myRestrictItems As Outlook.Items
Dim myItem As Outlook.MailItem
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = _
myNamespace.GetDefaultFolder(olFolderInbox)
Set myItems = myFolder.Items
Set myRestrictItems = myItems.Restrict("[Categories] = 'Business'")
For i = myRestrictItems.Count To 1 Step -1
myRestrictItems(i).Move myFolder.Folders("Business")
Next
End Sub
Also, you may find the AdvancedSearch method of the Application class helpful. The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
Please remember that you can set a suitable filter (View | View Settings |filter) on a folder and study the filter string on the SQL tab of the Filter dialog. Then you can construct any required filter string in the code.

Answer 2

If woudl be nice to use Items.Find/FindNext or Items.Restrict, but I cannot think of a query that would let you do what you want. If it is a one time thing, you have no choice but to loop through all items in a folder and for each item loop through all recipients and compare each recipient's entry id (Recipient.EntryID) with the sender entry id (MailItem.Sender.EntryId).