如何使用 VBA 获取主 SMTP 地址以外的 Microsoft Exchange 电子邮件地址

Question

我正在尝试使用 Excel 中的 VBA 从 Outlook.ExchangeUser 对象中提取联系信息。但是，到目前为止，我只能获得每个用户的主要 SMTP 地址 - 但如果可能的话，我希望获得链接到每个帐户的每个电子邮件地址。我们最近更名并获得了一个新域，因此新电子邮件地址已成为我们的主要电子邮件地址 - 但我还想提取所有旧地址，因为这些地址仍然可用（有些地址有不止一个旧地址电子邮件地址）。

一位同事给了我以下代码供我使用：

Sub GetAllGALMembers()

Dim i As Long, j As Long, lastRow As Long
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olGAL As Outlook.AddressList
Dim olEntry As Outlook.AddressEntries
Dim olMember As Outlook.AddressEntry

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olGAL = olNS.GetGlobalAddressList()

'Set Up Excel
Dim wb As Workbook, ws As Worksheet

'set the workbook:
Set wb = ThisWorkbook
'set the worksheet where you want to post Outlook data:
Set ws = wb.Sheets("Sheet1")

'clear all current entries
Cells.Select
Selection.ClearContents

'set and format headings in the worksheet:
ws.Cells(1, 1).Value = "First Name"
ws.Cells(1, 2).Value = "Last Name"
ws.Cells(1, 3).Value = "Email"
ws.Cells(1, 4).Value = "Title"
ws.Cells(1, 5).Value = "Department"
Application.ScreenUpdating = False
With ws.Range("A1:E1")

.Font.Bold = True
.HorizontalAlignment = xlCenter

End With

Set olEntry = olGAL.AddressEntries
On Error Resume Next
'first row of entries
j = 2

' loop through dist list and extract members
For i = 1 To olEntry.Count

Set olMember = olEntry.Item(i)

If olMember.AddressEntryUserType = olExchangeUserAddressEntry Then
'add to worksheet
ws.Cells(j, 1).Value = olMember.GetExchangeUser.LastName
ws.Cells(j, 2).Value = olMember.GetExchangeUser.FirstName
ws.Cells(j, 3).Value = olMember.GetExchangeUser.PrimarySmtpAddress
ws.Cells(j, 4).Value = olMember.GetExchangeUser.JobTitle
ws.Cells(j, 5).Value = olMember.GetExchangeUser.Department
j = j + 1
End If
Next i
Application.ScreenUpdating = True
'determine last data row, basis column B (contains Last Name):
lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row

'format worksheet data area:
ws.Range("A2:E" & lastRow).Sort Key1:=ws.Range("B2"), Order1:=xlAscending
ws.Range("A2:E" & lastRow).HorizontalAlignment = xlLeft
ws.Columns("A:E").EntireColumn.AutoFit

wb.Save

'quit the Outlook application:
applOutlook.Quit

'clear the variables:
Set olApp = Nothing
Set olNS = Nothing
Set olGAL = Nothing

End Sub

这工作得很好，但是我只能通过 .GetExchangeUser.PrimarySmtpAddress 属性.

为每个用户获得一个电子邮件地址

我检查了 Outlook Object Model Reference for the ExchangeUser Object，但这只包括 ExchangeUser.PrimarySmtpAddress 属性，没有其他相关属性。

有没有办法提取与用户关联的每个电子邮件地址？还是我只能获取主要地址而不能获取其他地址？

Answer 1

您需要使用 AddressEntry.PropertyAccessor.GetProperty 阅读 PR_EMS_AB_PROXY_ADDRESSES MAPI 属性（DASL 名称 http://schemas.microsoft.com/mapi/proptag/0x800F101F）。它是一个多值属性，所以你会得到一个字符串数组。

您可以在 OutlookSpy 中看到属性及其值（我是它的作者 - 单击 IMAPISession | QueryIdentity 按钮或 IAddrBook，然后深入到有问题的 GAL 条目）。

Answer 2

确实很有趣。当我回到我的工作站时，我将不得不查看 Excel 中的宏。有趣的。需要注意的是，Exchange Management Shell 中有一种方法，我假设它已安装，因为您可以在 Excel 中使用 Exchange 宏。我的假设可能是错误的，但无论如何：

Get-MailboxDatabase -IncludePreExchange2013 | Get-mailbox | % { Get-ADUser $_.Alias -Properties Surname, GivenName, @{N="EmailAddresses"; E={$_.ProxyAddresses | % {[string]::join("|",$_)}}}, Title, Department} | Export-csv <location you want to save it> -NoTypeInformation

如果您在 CSV 文件中已经有了要检查的所有用户，您还可以执行以下操作：

Import-csv <location of your source csv file> | Get-ADUser $_.Username -Properties Surname, GivenName, @{N="EmailAddresses"; E={$_.ProxyAddresses | % {[string]::join("|",$_)}}}, Title, Department} | Export-csv <location you want to save it> -NoTypeInformation

只需确保您的 CSV 文件中有一个名为 "Username" 的列，其中包含您要查找的帐户用户名。

如何使用 VBA 获取主 SMTP 地址以外的 Microsoft Exchange 电子邮件地址

How to get Microsoft Exchange email addresses other than the primary SMTP address using VBA

excel

outlook

vba

exchange-server