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

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

您可以在OutlookSpy中查看属性及其值（单击IMAPISession | QueryIdentity按钮或IAddrBook，然后深入查看相关的GAL条目。）

Answer 2

确实有趣。当我回到工作站时，我将不得不在Excel中查看宏。有趣。作为一个警告，Exchange管理外壳中有一种方法，我假设已安装，因为您可以在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文件中有一个名为“用户名”的列，其中包含您要查找的帐户用户名。

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

2 个答案: