X500 Address shows instead of email address when transferring to Excel sheet - excel

Question

I have been tasked with getting a list of all the users who sent mail to a mailbox in Outlook and transferring it to an excel sheet. Specifically, the sender's name, email address, as well as retrieving the sender's alias from the GAL address book.
For a somewhat large amount of the users, instead of their email address transferring, the X500 address is what shows up as follows: /O=OREGON STATE UNIVERSITY/OU=EXCHANGE ADMINISTRATIVE GROUP (FYDIBOHF23SPDLT)/CN=RECIPIENTS/CN
This is just an example I found online but the format is exactly the way it shows up in the Excel sheet.
I don't have a large knowledge of VBA, so maybe not getting too technical would be helpful.
Here's the code I have (the majority of which I found online):
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 oAL As Outlook.AddressList
Dim olAE As Outlook.AddressEntries
Dim oAE As Outlook.AddressEntry
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColB, strColC, strColD As String
enviro = CStr(Environ("USERPROFILE"))
'where to find excel sheet
strPath = enviro & "\Documents\EmailList.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
'Where to transfer the info
Set xlWB = xlApp.workbooks.Open(strPath)
Set xlSheet = xlWB.sheets("Sheet1")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("C" & xlSheet.Rows.Count).End(4000).Row
' where to find the information
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj
'extract the information
strColB = olItem.SenderName
strColC = olItem.SenderEmailAddress
strColD = olItem.Sender.GetExchangeUser.Alias
'Get the Exchange address
Dim olEU As Outlook.ExchangeUser
Dim oEDL As Outlook.ExchangeDistributionList
Dim recip As Outlook.Recipient
Set recip = Application.session.CreateRecipient(strColB)
If InStr(1, strColC, "/") > 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
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olOutlookContactAddressEntry
Set olEU = recip.AddressEntry.GetExchangeUser
If Not (olEU Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
Set oEDL = recip.AddressEntry.GetExchangeDistributionList
If Not (oEDL Is Nothing) Then
strColC = olEU.PrimarySmtpAddress
End If
End Select
End If
'write them in the excel sheet
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("C" & rCount) = strColC
xlSheet.Range("D" & rCount) = strColD
'Next row
rCount = rCount + 1
Next
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing

Answer 1

You never guard for the fact that GetExchangeUser can return null. And why do you call CreateRecipient? You already have the AddressEntry object
Off the top of my head:
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 oAL As Outlook.AddressList
Dim olAE As Outlook.AddressEntries
Dim oAE As Outlook.AddressEntry
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim olItem As Outlook.MailItem
Dim obj As Object
Dim strColB, strColC, strColD As String
Dim olEU As Outlook.ExchangeUser
dim olSender As Object
enviro = CStr(Environ("USERPROFILE"))
'where to find excel sheet
strPath = enviro & "\Documents\EmailList.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
'Where to transfer the info
Set xlWB = xlApp.workbooks.Open(strPath)
Set xlSheet = xlWB.sheets("Sheet1")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("C" & xlSheet.Rows.Count).End(4000).Row
' where to find the information
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
For Each obj In Selection
Set olItem = obj
'extract the information
strColB = olItem.SenderName
strColC = olItem.SenderEmailAddress
set olSender = olItem.Sender
if Not (olSender Is Nothing) Then
set olEU = olSender.GetExchangeUser
if (olEU Is Nothing) Then
strColD = ""
Else
strColC = olEU.PrimarySmtpAddress
strColD = olEU.Alias
End If
'write them in the excel sheet
xlSheet.Range("B" & rCount) = strColB
xlSheet.Range("C" & rCount) = strColC
xlSheet.Range("D" & rCount) = strColD
'Next row
rCount = rCount + 1
End If
Next
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set olItem = Nothing
Set obj = Nothing
Set currentExplorer = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing