Get primary SMTP mail from department in Outlook addressbook

Question

I achieved resolving Names with this code from an example:

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

This returns an e-mail address as expected if I use a Name like this:

MailSuchen("Max, Mustermann") => "[email protected]"

If I use a department Name it doesn't return anything. (Departments in my company have one corresponding mail address.)

MailSuchen("A 0123") => ""

On the other hand if I enter "A 0123" by hand in a new E-Mail as recipient and hit Alt-K it resolves to the right email address.

As I understood the resolve method should work the same as if I hit Alt-K.

Answer 1

Since both Outlook and Extended MAPI work, but OOM does not, I can only suggest using Redemption (I am its author) - something along the lines:

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