从Outlook查找GAL

Question

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

我找到了代码，并将其调整为搜索一个人的名字；但是，如果您有两个Bob Smith，我要求它在搜索时更具体，可以是电子邮件地址，也可以是别名。

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

有没有一种方法来搜索理想的别名或其次的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://docs.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

有没有办法返回以下Exchange值来合并该函数，以便它只在Exchange服务器中查看一次？

获取.Name .PrimarySmtpAddress .Manager .Manager.PrimarySmtpAddress .Manager.Alias

然后，我遍历并获取经理、经理和电子邮件。

我使用下面的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