传输到 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

Answer 1

您永远不会担心 GetExchangeUser 可以返回 null 的事实。你为什么叫 CreateRecipient？您已经拥有 AddressEntry 对象 在我脑海中浮现：

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