VBA-Excel 如何在 Outlook 中查找 Exchange 用户的电子邮件地址

Question

我一直在尝试根据输入的姓名导入联系人的电子邮件。我不太擅长宏编程，但找到了可行的代码。但是，它只能通过查找联系人文件夹中的信息来工作，我需要它来查找全局地址列表中的联系人，并返回与该人关联的电子邮件。我搜索过其他帖子，他们都想从 Outlook 中获取每个联系人并将其粘贴到 Excel 中。我只想根据输入的姓名在全局地址列表中搜索某个人，并让它返回该人的电子邮件。

这是我所拥有的：

Function GrabContactInfo(rRng As Range, iWanted As Integer) As String

Dim olA As Outlook.Application

Dim olNS As Namespace

Dim olAB As MAPIFolder

Dim lItem As Long   

Dim sNameWanted As String

Dim sRetValue As String

Set olA = New Outlook.Application
Set olNS = olA.GetNamespace("MAPI")
Set olAB = olNS.GetDefaultFolder(olFolderContacts)

Application.Volatile
sNameWanted = rRng.Value
sRetValue = "Not Found"

On Error Resume Next

For lItem = 1 To olAB.Items.Count
    With olAB.Items(lItem)
        If sNameWanted = .FullName Then
            Select Case iWanted
                Case 1
                    sRetValue = .CompanyName
                Case 2
                    sRetValue = .BusinessAddress
                Case 3
                    sRetValue = .BusinessAddressCity
                Case 4
                    sRetValue = .BusinessAddressState
                Case 5
                    sRetValue = .BusinessAddressPostalCode
                Case 6
                    sRetValue = .BusinessTelephoneNumber
                Case 7
                    sRetValue = .Email1Address
            End Select
        End If
    End With
Next lItem
olA.Quit
GrabContactInfo = sRetValue
End Function

任何信息都有帮助

Answer 1

您可以使用 Namespace.CreateRecipient / Recipient.Resolve 将名称解析为 Recipient 对象的实例，而不是循环遍历 Contacts 文件夹中的

all 项目。然后，您可以使用

AddressEntry.GetContact

将其解析为

ContactItem

对象的实例，或使用

AddressEntry.GetExchangeUser

获取

ExchangeUser

对象的实例：

Set olA = New Outlook.Application
Set olNS = olA.GetNamespace("MAPI")
set olRecip = olNS.CreateRecipient("Dmitry Streblechenko")
olRecip.Resolve
set olAddrEntry = olRecip.AddressEntry
set olCont = olAddrEntry.GetContact
if not (olCont Is Nothing) Then
  'this is a contact
  'olCont is ContactItem object
  MsgBox olCont.FullName
Else
  set olExchUser = olAddrEntry.GetExchangeUser
  if not (olExchUser Is Nothing) Then
    'olExchUser is ExchangeUser object
    MsgBox olExchUser.StreetAddress
  End If
End If 

Answer 2

可在 Excel 中使用的一个小函数来检索电子邮件地址 - 自动计算可能会很慢。

=查找邮箱(A2)

Function lookupEmail(name)
    lookupEmail = ""
    Dim objApp As New Outlook.Application
    Dim myNamespace As Outlook.Namespace
    Dim myRecipient As Outlook.recipient
    
    Set myNamespace = objApp.GetNamespace("MAPI")
    Set myRecipient = myNamespace.CreateRecipient(name)
    
    myRecipient.Resolve
    If myRecipient.Resolved Then
        lookupEmail = GetSMTPAdress(myRecipient)
 
    End If
End Function

Function GetSMTPAdress(recipient As Outlook.recipient)
    Dim pa As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
     Set pa = recipient.PropertyAccessor
     GetSMTPAdress = pa.GetProperty(PR_SMTP_ADDRESS)
End Function