如何通过邮箱电子邮件地址查找对应的Outlook.Account对象

假设Outlook中存在多个账户，分别为bob@example.com和bob@gmail.com：

每个账户可关联多个邮箱，本场景中bob@example.com账户下有3个邮箱：

• "bob@example.com"
• "Example Support"
• "Online Archive - bob@example.com"

bob@gmail.com账户仅关联1个同名邮箱：

• "bob@gmail.com"

该截图为右键点击"Example Support" > 数据文件属性... > 高级后的页面。

本次关联查询的目标邮箱为"Example Support"，其对应的电子邮件地址为support@example.com。

当前已实现仅通过邮箱电子邮件地址查找"Example Support"对应Outlook.Store对象的功能，代码如下：

Function GetStore(oApp As Outlook.Application, emailAddress As String) As Outlook.Store
    Dim oStore As Outlook.Store
    Set oStore = Nothing
    
    Dim s As Outlook.Store
    For Each s In oApp.Session.Stores
        If s.ExchangeStoreType = olExchangeMailbox Then
            Dim PR_MAILBOX_OWNER_ENTRYID As String
            PR_MAILBOX_OWNER_ENTRYID = "http://schemas.microsoft.com/mapi/proptag/0x661B0102"

            Dim ownerEntryId As String
            ownerEntryId = s.PropertyAccessor.BinaryToString(s.PropertyAccessor.GetProperty(PR_MAILBOX_OWNER_ENTRYID))
            
            Dim oAddressEntry As Outlook.AddressEntry
            Set oAddressEntry = oApp.Session.GetAddressEntryFromID(ownerEntryId)
            
            Dim oExhangeUser As Outlook.ExchangeUser
            Set oExhangeUser = oAddressEntry.GetExchangeUser()
            
            If oExhangeUser.PrimarySmtpAddress = emailAddress Then
                Set oStore = s
                Exit For
            End If
        End If
    Next s
    
    Set GetStore = oStore
End Function

• 调试过程中可查询到.SmtpAddress为bob@example.com的目标Outlook.Account对象，但无法找到该对象与"Example Support"邮箱的关联关系。
• "Example Support"邮箱对应的Outlook.Store对象，并非.SmtpAddress为bob@example.com的Outlook.Account对象的.DeliveryStore属性值。

仅给定邮箱的电子邮件地址时，如何查找该邮箱对应的Outlook.Account对象？

实现逻辑为：先通过已有GetStore方法拿到目标邮箱对应的Store对象，再遍历所有Account，通过MAPI属性比对Store所属的账户EntryID和Account的EntryID，匹配成功即可得到对应Account。

实现代码如下：

Function GetAccountByMailboxAddress(oApp As Outlook.Application, emailAddress As String) As Outlook.Account
    ' 先获取目标邮箱对应的Store对象
    Dim targetStore As Outlook.Store
    Set targetStore = GetStore(oApp, emailAddress)
    If targetStore Is Nothing Then
        Set GetAccountByMailboxAddress = Nothing
        Exit Function
    End If
    
    Const PR_MAILBOX_OWNER_ENTRYID As String = "http://schemas.microsoft.com/mapi/proptag/0x661B0102"
    ' 获取目标Store的所有者EntryID
    Dim targetOwnerEntryId As String
    targetOwnerEntryId = targetStore.PropertyAccessor.BinaryToString(targetStore.PropertyAccessor.GetProperty(PR_MAILBOX_OWNER_ENTRYID))
    
    ' 遍历所有账户匹配所有者EntryID
    Dim oAccount As Outlook.Account
    For Each oAccount In oApp.Session.Accounts
        If oAccount.AccountType = olExchange Then
            Dim accountEntryId As String
            accountEntryId = oAccount.CurrentUser.AddressEntry.ID
            If accountEntryId = targetOwnerEntryId Then
                Set GetAccountByMailboxAddress = oAccount
                Exit Function
            End If
        End If
    Next oAccount
    
    Set GetAccountByMailboxAddress = Nothing
End Function

调用示例 #

Sub TestFindAccount()
    Dim oApp As New Outlook.Application
    Dim targetAccount As Outlook.Account
    ' 传入目标邮箱地址support@example.com
    Set targetAccount = GetAccountByMailboxAddress(oApp, "support@example.com")
    If Not targetAccount Is Nothing Then
        Debug.Print "对应账户SMTP地址：" & targetAccount.SmtpAddress
    Else
        Debug.Print "未找到匹配的账户"
    End If
End Sub

内容的提问来源于stack exchange，提问作者symbiont