I am trying to update the contact list from the GAL.
The system for updating a contact list is that my macro deletes all the contacts in a given folder then adds contacts from the GAL where the contacts are always up to date. This creates the problem that if you add home address or personal phone to the contact you lose them once you update the contact list.
I have a macro to look in the GAL for contacts that match a specific requirement (our office location).
Now the tricky part
If a contact is (based on full name) already in my contact list then I want to update all company dedicated fields, (such as: Company name, position and so on) BUT to leave all other fields as they are.
If the contact is not in my contact list: Add it - WORKS
If a contact in my contact list has not been matched with anything from the GAL (means the person left the company) then delete all company dedicated fields (same as in 1).
My code (adds a contact based on location)
Sub GetAllGALMembers()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olGAL As Outlook.AddressList
Dim olEntry As Outlook.AddressEntries
Dim olMember As Outlook.AddressEntry
Dim objItem As Outlook.ContactItem
Dim myContacts As Outlook.MAPIFolder
Dim myFolder As MAPIFolder
Dim myItems As Items
Set mySession = New Outlook.Application
Set myNS = mySession.GetNamespace("MAPI")
Set myContacts = myNS.GetDefaultFolder(olFolderContacts)
Set myFolder = myContacts.Folders("Prague")
Set myItems = myFolder.Items
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olGAL = olNS.GetGlobalAddressList()
Set olEntry = olGAL.AddressEntries
On Error Resume Next
' loop through dist list and extract members
Dim i As Long
For i = 1 To olEntry.Count
Set olMember = olEntry.Item(i)
If olMember.AddressEntryUserType = olExchangeUserAddressEntry Then
strLocation = olMember.GetExchangeUser.OfficeLocation
If strLocation = "PRG" Then
Set objItem = olApp.CreateItem(olContactItem)
With objItem
.firstName = olMember.GetExchangeUser.firstName
.Last = olMember.GetExchangeUser.lastName
.FullName = olMember.GetExchangeUser.Name
.Email1Address = olMember.GetExchangeUser.PrimarySmtpAddress
.BusinessTelephoneNumber = olMember.GetExchangeUser.BusinessTelephoneNumber
.MobileTelephoneNumber = olMember.GetExchangeUser.MobileTelephoneNumber
.CompanyName = olMember.GetExchangeUser.CompanyName
.Email2DisplayName = olMember.GetExchangeUser.DisplayType
.Save
End With
End If
End If
Next i
End Sub