传输到Excel工作表时，X500地址显示而不是电子邮件地址

Question

我的任务是获取所有用户的列表，这些用户将邮件发送到Outlook中的邮箱并将其传输到Excel工作表。具体来说，是发件人的姓名，电子邮件地址，以及从GAL地址簿中检索发件人的别名。

对于相当多的用户，而不是他们的电子邮件地址转移，X500地址显示如下：/ O = OREGON STATE UNIVERSITY / OU = EXCHANGE ADMINISTRATIVE GROUP（FYDIBOHF23SPDLT）/ CN = RECIPIENTS / CN

这只是我在网上找到的一个例子，但格式与它在Excel表格中的显示方式完全相同。

我对VBA知之甚少，所以也许不会太过技术化会有所帮助。

这是我的代码（我在网上找到的大部分代码）：

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