CODEWITHSUNDEEP
vbacdo.messagegal
GymLeaderTalon
GymLeaderTalon

Reputation: 1

VBA to Open Global Address List no longer functioning after Office 365 update

I'm using the below code to open the Global Address Window, but since updating to Office 365 it is no longer opening. I have done many searches online but can't find anyone experiencing the same issue. Can anyone assist?

CODE:

Dim cdoSession, cdoAddressBook, olkRecipients, objAE
On Error Resume Next
Set cdoSession = CreateObject("MAPI.Session")
cdoSession.Logon "", "", False, False
Set olkRecipients = cdoSession.AddressBook(, "Global Address List", 0, False)
For Each objAE In olkRecipients
    'MsgBox objAE.Name
    
TextBox1.Value = objAE.Name

Next
Set olkRecipients = Nothing
cdoSession.Logoff
Set cdoSession = Nothing

Upvotes: 0

Views: 503

Answers (1)

GymLeaderTalon
GymLeaderTalon

Reputation: 1

I added a reference to Microsoft Outlook 16 Object Library and then updated the code to the below, it is functioning appropriately now:

Dim olApp As Outlook.Application
Dim oDialog As SelectNamesDialog
Dim oGAL As AddressList
Dim myAddrEntry As AddressEntry
Dim exchUser As Outlook.ExchangeUser

Dim AliasName As String
Dim FirstName As String
Dim LastName As String
Dim EmailAddress As String

Set olApp = GetObject(, "Outlook.Application")
Set oDialog = olApp.Session.GetSelectNamesDialog
Set oGAL = olApp.GetNamespace("MAPI").AddressLists("Global Address List")

With oDialog
        .AllowMultipleSelection = False
        .InitialAddressList = oGAL
        .ShowOnlyInitialAddressList = True
        If .Display Then
            AliasName = oDialog.Recipients.Item(1).Name
            Set myAddrEntry = oGAL.AddressEntries(AliasName)
            Set exchUser = myAddrEntry.GetExchangeUser

            If Not exchUser Is Nothing Then
                ThisName = exchUser.Name
                FirstName = exchUser.FirstName
                LastName = exchUser.LastName
                EmailAddress = exchUser.PrimarySmtpAddress
                '...
                TextBox1.Value = ThisName
            End If
        End If
    End With
Set olApp = Nothing
Set oDialog = Nothing
Set oGAL = Nothing
Set myAddrEntry = Nothing
Set exchUser = Nothing

Upvotes: 0

Related Questions