从vba中outlook通讯簿中的部门获取主smtp邮件

我已经搜索了很长时间，这个周末我找到了一个解决方案，但不幸的是，一个未保存的工作簿将我的结果丢失在了空间中，我似乎再也找不到这篇文章了

我通过一个示例使用以下代码实现了名称解析：

Function MailSuchen(strSuchen As String)
    Dim objEmpfaenger As Outlook.Recipient
    Dim objExchBenutzer As Outlook.ExchangeUser
    Dim objExchListe As Outlook.ExchangeDistributionList
    
    Set objEmpfaenger = Outlook.Application.Session.CreateRecipient(strSuchen)
    objEmpfaenger.Resolve
    
    If objEmpfaenger.Resolved Then
        Select Case objEmpfaenger.AddressEntry.AddressEntryUserType
            Case OlAddressEntryUserType.olExchangeUserAddressEntry
                Set objExchBenutzer = objEmpfaenger.AddressEntry.GetExchangeUser
                If Not (objExchBenutzer Is Nothing) Then
                    MailSuchen = objExchBenutzer.PrimarySmtpAddress
                    Exit Function
                End If
            Case OlAddressEntryUserType.olExchangeDistributionListAddressEntry
                Set objExchListe = objEmpfaenger.AddressEntry.GetExchangeDistributionList
                If Not (objExchListe Is Nothing) Then
                    MailSuchen = objExchListe.PrimarySmtpAddress
                End If
        End Select
    End If
End Function

如果我使用以下名称，则会返回预期的电子邮件地址：

MailSuchen("Max, Mustermann") => "Max.Mustermann@domain.de"

如果我使用部门名称，它不会返回任何内容。（我公司的部门只有一个对应的邮件地址）

另一方面，如果我在一封新的电子邮件中手工输入“A 0123”作为收件人，并点击Alt-K，它将解析为正确的邮件地址

据我所知，resolve方法的工作原理应该与我点击Alt-K时相同

有人有什么暗示吗

谢谢,，

---

MZiegaus

由于Outlook和Extended MAPI都能工作，但OOM不能，我只能建议使用-大致如下：

Function MailSuchen(strSuchen As String)
  set rSession = CreateObject("Redemption.RDOSession")
  rSession.MAPIOBJECT = Outlook.Application.Session.MAPIOBJECT
  Set objEmpfaenger = rSession.AddressBook.ResolveName(strSuchen)
  MailSuchen = objEmpfaenger.SMTPAddress
End Function

---

如果你一步一步地检查你的代码，它会在哪里失败？@DmitryStreblechenko:它根本不会失败。它只是不能解析“A 0123”，而手动写入“A 0123”并点击Alt-K的方式可以正确解析。这就是我为什么感到困惑的原因。如果我逐级检查代码，它会跳过If循环，因为objEmpfaenger.Resolved=False，但如上所述，我希望它会解决，因为我在新邮件表单中手动输入它时会解决。我刚刚了解到，对于某些版本，它可能不是快捷键alt-k，而是ctrl-k。因此，无论哪种方式，我的意思都是在新邮件表单中强制自动解析。当您在Outlook中解析名称时，Outlook是否找到多个匹配项？好的，自从启用Option Explicit后，我通过对对象进行尺寸标注来实现这一点。但是现在Redemption抛出了一个MAPI\u E\u暧昧的\u RECIP错误。我不明白为什么。。。当我在Outlook通讯录中搜索时，只有一个条目，它在新的邮件表单中解析得很好，就像我上面提到的那样。应该只有一个这样的条目。。。但救赎说还有更多。至少这解释了OOM无法解析。我只是不知道这个模棱两可的条目是从哪里来的。。我会设法调查地址簿的选择。这是我现在能想到的唯一一件事。所以我尝试将“Set AddrBuch=Session.addresslist.Item（“Globale-addressliste”）”添加到您的代码片段中，但它仍然抛出不明确的错误。但是当我手动搜索时，我的地址簿只显示“A 0123”的一个条目…你可以尝试ResolveNameEx-它返回匹配列表。试着列举它们。请记住，如果您有“A 0123”和“A 01234”，它们都将匹配。

Function MailSuchen(strSuchen As String)
  set rSession = CreateObject("Redemption.RDOSession")
  rSession.MAPIOBJECT = Outlook.Application.Session.MAPIOBJECT
  Set objEmpfaenger = rSession.AddressBook.ResolveName(strSuchen)
  MailSuchen = objEmpfaenger.SMTPAddress
End Function