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

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

Dmitry Streblechenko Dmitry Streblechenko · Accepted Answer · 2017-08-09T17:16:05

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

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

1 Answers