Lookup GAL from Outlook

Question

我正在构建一个工具，需要在Outlook中查找GAL，以查找某个员工并返回他们的电子邮件地址，他们的经理和经理的电子邮件地址，最后是他们的经理和经理的电子邮件地址。

我找到了代码并对其进行了调整以搜索一个人的名字;但是，如果你有两个鲍勃史密斯，我要求在搜索中更具体，无论是通过电子邮件地址还是别名。

我找到的任何代码都会创建一个数组，其中包含交换服务器中的所有用户;但是，对于数百万条员工记录，这需要大量时间，并且每周运行一次以更新信息。

有没有办法理想地按别名或其次按SMTP电子邮件地址进行搜索？

我找到了代码的版本，并对其进行了修改以满足我的要求，但仍然无法通过别名或电子邮件地址找到。如果我手动执行此操作，我可以单击高级搜索并键入别名，或者单击"更多列"并搜索别名并出现正确的结果。

我可以在VBA代码中定义"更多列"吗？

Dim myolApp As Outlook.Application
Dim myNameSpace As Namespace
Dim myAddrList As AddressList
Dim myAddrEntry As AddressEntry
Dim AliasName As String
Dim i As Integer, r As Integer
Dim c As Range
Dim EndRow As Integer, n As Integer
Dim exchUser As Outlook.ExchangeUser
Set myolApp = CreateObject("Outlook.Application")
Set myNameSpace = myolApp.GetNamespace("MAPI")
Set myAddrList = myNameSpace.AddressLists("Global Address List")
Dim FullName As String, LastName As String, FirstName As String
Dim LDAP As String, PhoneNum As String
Dim StartRow As Integer
EndRow = Cells(Rows.Count, 1).End(xlUp).Row
StartRow = 2
For Each c In Range("I" & StartRow & ":I" & CStr(EndRow))
AliasName = LCase(Trim(c))
c = AliasName
Set myAddrEntry = myAddrList.AddressEntries(AliasName)
Set exchUser = myAddrEntry.GetExchangeUser
If Not exchUser Is Nothing Then
c.Offset(0, 1) = exchUser.FirstName
c.Offset(0, 2) = exchUser.LastName
c.Offset(0, 3) = exchUser.Alias
c.Offset(0, 4) = exchUser.PrimarySmtpAddress
c.Offset(0, 5) = exchUser.Manager
'etc...
End If
Next c

Answer 1

您是否检查过CreateRecipient命名空间？ https://learn.microsoft.com/en-us/office/vba/api/outlook.namespace.createrecipient

您可以尝试创建一个recipient对象，将别名传递给CreateRecipient方法：

Set myNamespace = Application.GetNamespace("MAPI")
Set recip = myNamespace.CreateRecipient("YourAlias")
recip.Resolve

当然，您应该通过检查resolved属性来检查您的收件人是否已正确解析：

If recip.Resolved Then 'Do something

获取收件人后，可以使用收件人对象中AdressEntry属性中的GetExchangeUser方法从中创建 Exchange 用户。

Set exchUser = recip.AddressEntry.GetExchangeUser
Debug.Print exchUser.PrimarySmtpAddress

我相信你可以从那里解决它！

Answer 2

我已经能够使用以下函数找到解决方法。

Function GetName(strAcc As String) As Variant
Dim lappOutlook As Outlook.Application
Dim lappNamespace As Outlook.Namespace
Dim lappRecipient As Outlook.Recipient
'Dim strAcc As String
Dim maxTries As Long
Dim errCount As Long
Set lappOutlook = CreateObject("Outlook.Application")
Set lappNamespace = lappOutlook.GetNamespace("MAPI")

Set lappRecipient = lappNamespace.CreateRecipient(strAcc)
maxTries = 2000
On Error GoTo errorResume
Retry:
DoEvents
' For testing error logic. No error with my Excel 2013 Outlook 2013 setup.
' Should normally be commented out
'Err.Raise 287
lappRecipient.Resolve
On Error GoTo 0

Set olAddrEntry = lappRecipient.AddressEntry

If lappRecipient.Resolved Then
Set olexchuser = olAddrEntry.GetExchangeUser
GetName = olexchuser.Name
Else
GetName = "Unable To Validate LDAP"
End If
ExitRoutine:
Set lappOutlook = Nothing
Set lappNamespace = Nothing
Set lappRecipient = Nothing
Exit Function
errorResume:
errCount = errCount + 1
' Try until Outlook responds
If errCount > maxTries Then
' Check if Outlook is there and Resolve is the issue
lappNamespace.GetDefaultFolder(olFolderInbox).Display
GoTo ExitRoutine
End If
'Debug.Print errCount & " - " & Err.Number & ": " & Err.Description
Resume Retry
End Function

有没有办法返回以下交换值来合并函数，使其只在交换服务器中查找一次？

获得。名字 .主地址 .经理 .Manager.PrimarySmtpAddress .经理.别名

然后我循环访问并获取经理，经理和电子邮件。

我使用以下 SUB 能够提取所需的信息(在构建时进入消息框，但完成后数据将填充表(。

Sub GetDetails()
Dim Name As String, Email As String, Manager As String, ManagersEmail As String, MD As String, MDEmail As String, Lookup As String
Lookup = GetManagerAlias("3511931")    '("3359820")
Name = GetName(Lookup)
Email = GetEmail(Lookup)
Manager = GetManager(Lookup)
ManagersEmail = GetManagersEmail(Lookup)
MD = GetManager(GetManagerAlias(Lookup))
MDEmail = GetManagersEmail(GetManagerAlias(Lookup))
MsgBox Name & vbNewLine & Email & vbNewLine & Manager & vbNewLine & ManagersEmail & vbNewLine & MD & vbNewLine & MDEmail
End Sub