asked on

Update Local outlook contacts from Exchange 2010 GAL automaticlly

Hello, I have been asked to look at automating the sync from out GAL in exchange 2010 to outlook 2010. Which will then in turn update all mobile users contacts.

Anyone found a good way of doing this as from reading stuff this is not a built in feature and is all 3rd party app? If so anyone offer any suggestions on good ones?

Regards

Darren

Adam Brown

As long as a user has a mailbox in Exchange 2010, they will periodically connect to Exchange to update the local address book. How exactly are you looking to automate this? Do you want to make sure the Offline Address Book (the local version of the GAL that gets downloaded) gets updated more often?

ASKER CERTIFIED SOLUTION

David Lee

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

DarrenEley

ASKER

Thank you, I failed to see this one when I was having a look around.

Thank you.

David Lee

You're welcome. Give me a shout if you need any modifications to the script.

David Lee

Darren,

Here's my solution that implements everything we discussed in the question I linked to above. I changed the linking field from Nickname to User1 and added Nickname to the fields the script populates. I set Nickname to be LastName, FirstName. I can change that if you need me to.

Follow these instructions to use it.

1. Open Notepad
2. Copy the code below and paste it into Notepad
3. Save the file. Name it anything you choose, just be sure the extension is .vbs
4. Double-click the saved file to give the script a test run
5. Create a scheduled task
6. Set the task to run this script

'--> Create some constants
    Const olFolderContacts = 10

'--> Create some variables
    Dim excApp, excWkb, excWks, olkApp, olkSes, olkFld, olkCon, objADRDSE, adoCon, adoCmd, adoRS, adoField, intRow, strFields, strSource, arrRooms, strDNC, strManager, objManager

'--> Initialize variables
    strFields = "manager,postalCode,st,l,roomNumber,streetAddress,Department,Company,physicalDeliveryOfficeName,mobile,TelephoneNumber,mail,title,givenName,SN,samAccountName"

'--> Turn error handling off
On Error Resume Next

'--> Create the Excel spreadsheet and write a header to it
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Add
    Set excWks = excWkb.Worksheets(1)
    With excWks
        .Cells(1, 1) = "Account"
        .Cells(1, 2) = "Last Name"
        .Cells(1, 3) = "First Name"
        .Cells(1, 4) = "Title"
        .Cells(1, 5) = "Email"
        .Cells(1, 6) = "Telephone"
        .Cells(1, 7) = "Mobile"
        .Cells(1, 8) = "Office"
        .Cells(1, 9) = "Company"
        .Cells(1, 10) = "Department"
        .Cells(1, 11) = "Street"
        .Cells(1, 12) = "Room"
        .Cells(1, 13) = "City"
        .Cells(1, 14) = "State"
        .Cells(1, 15) = "Zip"
        .Cells(1, 16) = "Manager"
    End With
    
'--> Connect to and read AD
    Set objADRDSE = GetObject("LDAP://RootDSE")
    strDNC = objADRDSE.Get("defaultnamingcontext")
    strSource = "'LDAP://" & strDNC & "'"
    Set adoCon = CreateObject("ADODB.Connection")
    adoCon.CursorLocation = 3
    adoCon.Provider = "ADsDSOObject"
    adoCon.Open "ADSI"
    Set adoCmd = CreateObject("ADODB.Command")
    adoCmd.ActiveConnection = adoCon
    adoCmd.CommandText = "SELECT " & strFields & " FROM " & strSource & " Where objectClass='user' AND objectCategory='Person' ORDER BY samAccountName"
    adoCmd.Properties("Size Limit") = 5000
    adoCmd.Properties("Page Size") = 100
    adoCmd.Properties("Timeout") = 30
    adoCmd.Properties("Cache Results") = False
    Set adoRS = adoCmd.Execute()
    If Not adoRS.EOF Then
        intRow = 2
        Do While Not adoRS.EOF
            With adoRS
                For Each adoField In .Fields
                    Select Case LCase(adoField.Name)
                        Case "samaccountname"
                            excWks.Cells(intRow, 1) = adoField.Value
                        Case "sn"
                            excWks.Cells(intRow, 2) = adoField.Value
                        Case "givenname"
                            excWks.Cells(intRow, 3) = adoField.Value
                        Case "title"
                            excWks.Cells(intRow, 4) = adoField.Value
                        Case "mail"
                            excWks.Cells(intRow, 5) = adoField.Value
                        Case "telephonenumber"
                            excWks.Cells(intRow, 6) = adoField.Value
                        Case "mobile"
                            excWks.Cells(intRow, 7) = adoField.Value
                        Case "physicaldeliveryofficename"
                            excWks.Cells(intRow, 8) = adoField.Value
                        Case "company"
                            excWks.Cells(intRow, 9) = adoField.Value
                        Case "department"
                            excWks.Cells(intRow, 10) = adoField.Value
                        Case "streetaddress"
                            excWks.Cells(intRow, 11) = adoField.Value
                        Case "roomnumber"
                            If Not IsNull(adoField.Value) Then
                                arrRooms = adoField.Value
                                excWks.Cells(intRow, 12) = arrRooms(0)
                            End If
                        Case "l"
                            excWks.Cells(intRow, 13) = adoField.Value
                        Case "st"
                            excWks.Cells(intRow, 14) = adoField.Value
                        Case "postalcode"
                            excWks.Cells(intRow, 15) = adoField.Value
                        Case "manager"
                            If Not IsNull(adoField.Value) Then
                                Set objManager = GetObject("LDAP://" & adoField.Value)
                                strManager = objManager.DisplayName
                            Else
                                strManager = ""
                            End If
                            excWks.Cells(intRow, 16) = strManager
                            Set objManager = Nothing
                            strManager = ""
                    End Select
                Next
                intRow = intRow + 1
                .MoveNext
            End With
        Loop
    End If

'--> Clean up AD objects
    adoRS.Close
    Set adoRS = Nothing
    adoCon.Close
    Set adoCon = Nothing

'--> Connect to Outlook
    Set olkApp = CreateObject("Outlook.Application")
    Set olkSes = olkApp.GetNamespace("MAPI")
    olkSes.Logon olkApp.DefaultProfileName
    Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Items
    
'--> Read the contacts downloaded from AD and add, update, or delete contacts from Outlook
    For intRow = 2 To excWks.UsedRange.rows.Count
        If excWks.Cells(intRow, 2).Value = "" Or excWks.Cells(intRow, 3).Value = "" Or excWks.Cells(intRow, 5).Value = "" Then
        Else
            Set olkCon = olkFld.Find("[User1] = '" & Replace(excWks.Cells(intRow, 1).Value, "'", "''") & "'")
            If TypeName(olkCon) = "Nothing" Then
                Set olkCon = olkFld.Add
                olkCon.User1 = excWks.Cells(intRow, 1).Value
            End If
            With olkCon
                .LastName = excWks.Cells(intRow, 2).Value
                .FirstName = excWks.Cells(intRow, 3).Value
                .JobTitle = excWks.Cells(intRow, 4).Value
                .Email1Address = excWks.Cells(intRow, 5).Value
                .BusinessTelephoneNumber = excWks.Cells(intRow, 6).Value
                .MobileTelephoneNumber = excWks.Cells(intRow, 7).Value
                .OfficeLocation = excWks.Cells(intRow, 8).Value
                .CompanyName = excWks.Cells(intRow, 9).Value
                .Department = excWks.Cells(intRow, 10).Value
                .BusinessAddressStreet = excWks.Cells(intRow, 11).Value
                .BusinessAddressCity = excWks.Cells(intRow, 13).Value
                .BusinessAddressState = excWks.Cells(intRow, 14).Value
                .BusinessAddressPostalCode = excWks.Cells(intRow, 15).Value
                .ManagerName = excWks.Cells(intRow, 16).Value
                .NickName = .LastName & ", " & .FirstName
                .Categories = "AutoUpdate"
                .Save
            End With
            Set olkCon = Nothing
        End If
    Next

'--> Disconnect from Outlook
    olkSes.Logoff
    Set olkFld = Nothing
    Set olkSes = Nothing
    Set olkApp = Nothing

'--> Save and close the spreadsheet, then close Excel
    excWkb.Close False
    Set excWks = Nothing
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    
'--> Notify the user that the script has finished then terminate processing
    WScript.Quit

Open in new window

DarrenEley

ASKER

Hiya, Thank you so much, is there anything in there for adding exceptions?

Thanks in advance.

Regards

Darren

David Lee

Oops, I forgot about that. Please tell me again how you want the exceptions to work. Do you want to match based on the email address? Also, do you want the exceptions in the script or would you prefer having them in a file that the script reads?

DarrenEley

ASKER

Hiya, which ever is best for you, Email exceptions would be good as I can manually add the email address I don't want in the sync in to the script as they will not be changing much after its setup.

Really appreciate you assistance with this.

Regards

Darren

David Lee

Darren,

I've added the exception handling. You'll need to create a text file and enter the exceptions in it, one exception per line. Exception processing keys on the email address. You'll also need to edit the code and add the path to and name of the exception file. See the comment in the code to see where that goes.

Note, that I have not tested this version of the code. I don't have access to an Exchange server at the moment and therefore cannot test it right now. I think I got it right, but you should test to make sure.

'--> Create some constants
    'On the next line, edit the path to a file of exceptions (addrsses you don't want to copy over from AD)
    Const EXECPTION_FILE = "c:\MyExceptions.txt"
    Const olFolderContacts = 10

'--> Create some variables
    Dim excApp, excWkb, excWks, olkApp, olkSes, olkFld, olkCon, objADRDSE, adoCon, adoCmd, adoRS, adoField, intRow, strFields, strSource, arrRooms, strDNC, strManager, objManager
    Dim objFSO, objFil, strBuffer, dicExceptions

'--> Initialize variables
    strFields = "manager,postalCode,st,l,roomNumber,streetAddress,Department,Company,physicalDeliveryOfficeName,mobile,TelephoneNumber,mail,title,givenName,SN,samAccountName"

'--> Turn error handling off
On Error Resume Next

'--> Read a list of exceptions in from a text file
    Set dicExceptions = CreateObject("Scripting.Dictionary")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If objFSO.FileExists(EXCEPTION_FILE) Then
        Set objFil = objFSO.OpenTextFile(EXECPTION_FILE)
        Do Until objFil.AtEndOfStream
            strBuffer = LCase(objFil.ReadLine)
            dicExceptions.Add strBuffer, strBuffer
        Loop
        objFil.Close
        Set objFil = Nothing
    End If
    Set objFSO = Nothing

'--> Create the Excel spreadsheet and write a header to it
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Add
    Set excWks = excWkb.Worksheets(1)
    With excWks
        .Cells(1, 1) = "Account"
        .Cells(1, 2) = "Last Name"
        .Cells(1, 3) = "First Name"
        .Cells(1, 4) = "Title"
        .Cells(1, 5) = "Email"
        .Cells(1, 6) = "Telephone"
        .Cells(1, 7) = "Mobile"
        .Cells(1, 8) = "Office"
        .Cells(1, 9) = "Company"
        .Cells(1, 10) = "Department"
        .Cells(1, 11) = "Street"
        .Cells(1, 12) = "Room"
        .Cells(1, 13) = "City"
        .Cells(1, 14) = "State"
        .Cells(1, 15) = "Zip"
        .Cells(1, 16) = "Manager"
    End With
    
'--> Connect to and read AD
    Set objADRDSE = GetObject("LDAP://RootDSE")
    strDNC = objADRDSE.Get("defaultnamingcontext")
    strSource = "'LDAP://" & strDNC & "'"
    Set adoCon = CreateObject("ADODB.Connection")
    adoCon.CursorLocation = 3
    adoCon.Provider = "ADsDSOObject"
    adoCon.Open "ADSI"
    Set adoCmd = CreateObject("ADODB.Command")
    adoCmd.ActiveConnection = adoCon
    adoCmd.CommandText = "SELECT " & strFields & " FROM " & strSource & " Where objectClass='user' AND objectCategory='Person' ORDER BY samAccountName"
    adoCmd.Properties("Size Limit") = 5000
    adoCmd.Properties("Page Size") = 100
    adoCmd.Properties("Timeout") = 30
    adoCmd.Properties("Cache Results") = False
    Set adoRS = adoCmd.Execute()
    If Not adoRS.EOF Then
        intRow = 2
        Do While Not adoRS.EOF
            With adoRS
                For Each adoField In .Fields
                    Select Case LCase(adoField.Name)
                        Case "samaccountname"
                            excWks.Cells(intRow, 1) = adoField.Value
                        Case "sn"
                            excWks.Cells(intRow, 2) = adoField.Value
                        Case "givenname"
                            excWks.Cells(intRow, 3) = adoField.Value
                        Case "title"
                            excWks.Cells(intRow, 4) = adoField.Value
                        Case "mail"
                            excWks.Cells(intRow, 5) = adoField.Value
                        Case "telephonenumber"
                            excWks.Cells(intRow, 6) = adoField.Value
                        Case "mobile"
                            excWks.Cells(intRow, 7) = adoField.Value
                        Case "physicaldeliveryofficename"
                            excWks.Cells(intRow, 8) = adoField.Value
                        Case "company"
                            excWks.Cells(intRow, 9) = adoField.Value
                        Case "department"
                            excWks.Cells(intRow, 10) = adoField.Value
                        Case "streetaddress"
                            excWks.Cells(intRow, 11) = adoField.Value
                        Case "roomnumber"
                            If Not IsNull(adoField.Value) Then
                                arrRooms = adoField.Value
                                excWks.Cells(intRow, 12) = arrRooms(0)
                            End If
                        Case "l"
                            excWks.Cells(intRow, 13) = adoField.Value
                        Case "st"
                            excWks.Cells(intRow, 14) = adoField.Value
                        Case "postalcode"
                            excWks.Cells(intRow, 15) = adoField.Value
                        Case "manager"
                            If Not IsNull(adoField.Value) Then
                                Set objManager = GetObject("LDAP://" & adoField.Value)
                                strManager = objManager.DisplayName
                            Else
                                strManager = ""
                            End If
                            excWks.Cells(intRow, 16) = strManager
                            Set objManager = Nothing
                            strManager = ""
                    End Select
                Next
                intRow = intRow + 1
                .MoveNext
            End With
        Loop
    End If

'--> Clean up AD objects
    adoRS.Close
    Set adoRS = Nothing
    adoCon.Close
    Set adoCon = Nothing

'--> Connect to Outlook
    Set olkApp = CreateObject("Outlook.Application")
    Set olkSes = olkApp.GetNamespace("MAPI")
    olkSes.Logon olkApp.DefaultProfileName
    Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Items
    
'--> Read the contacts downloaded from AD and add, update, or delete contacts from Outlook
    For intRow = 2 To excWks.UsedRange.rows.Count
        If excWks.Cells(intRow, 2).Value = "" Or excWks.Cells(intRow, 3).Value = "" Or excWks.Cells(intRow, 5).Value = "" Then
            'The first anem, last name, or email address is empty.  Skip the entry.
        Else
            If dicExceptions.Exists(LCase(excWks.Cells(intRow, 5).Value)) Then
                'The address is in the exception list, so skip it
            Else
                Set olkCon = olkFld.Find("[User1] = '" & Replace(excWks.Cells(intRow, 1).Value, "'", "''") & "'")
                If TypeName(olkCon) = "Nothing" Then
                    Set olkCon = olkFld.Add
                    olkCon.User1 = excWks.Cells(intRow, 1).Value
                End If
                With olkCon
                    .LastName = excWks.Cells(intRow, 2).Value
                    .FirstName = excWks.Cells(intRow, 3).Value
                    .JobTitle = excWks.Cells(intRow, 4).Value
                    .Email1Address = excWks.Cells(intRow, 5).Value
                    .BusinessTelephoneNumber = excWks.Cells(intRow, 6).Value
                    .MobileTelephoneNumber = excWks.Cells(intRow, 7).Value
                    .OfficeLocation = excWks.Cells(intRow, 8).Value
                    .CompanyName = excWks.Cells(intRow, 9).Value
                    .Department = excWks.Cells(intRow, 10).Value
                    .BusinessAddressStreet = excWks.Cells(intRow, 11).Value
                    .BusinessAddressCity = excWks.Cells(intRow, 13).Value
                    .BusinessAddressState = excWks.Cells(intRow, 14).Value
                    .BusinessAddressPostalCode = excWks.Cells(intRow, 15).Value
                    .ManagerName = excWks.Cells(intRow, 16).Value
                    .NickName = .LastName & ", " & .FirstName
                    .Categories = "AutoUpdate"
                    .Save
                End With
                Set olkCon = Nothing
            End If
        End If
    Next

'--> Disconnect from Outlook
    olkSes.Logoff
    Set olkFld = Nothing
    Set olkSes = Nothing
    Set olkApp = Nothing

'--> Save and close the spreadsheet, then close Excel
    excWkb.Close False
    Set excWks = Nothing
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    
'--> Kill other objects
    Set dicExceptions = Nothing
    
'--> Notify the user that the script has finished then terminate processing
    WScript.Quit

Open in new window

DarrenEley

ASKER

Thank you so very much, I will give it a go now and see how it goes.

Regards

Darren

DarrenEley

ASKER

Hiya, Thank you. Tried it but the sync does not happen, followed the instructions and put the txt file in the root of C:\

Thank you.

Darren

David Lee

I had a couple of typos. I've corrected them.

'--> Create some constants
    'On the next line, edit the path to a file of exceptions (addrsses you don't want to copy over from AD)
    Const EXCEPTION_FILE = "c:\MyExceptions.txt"
    Const olFolderContacts = 10

'--> Create some variables
    Dim excApp, excWkb, excWks, olkApp, olkSes, olkFld, olkCon, objADRDSE, adoCon, adoCmd, adoRS, adoField, intRow, strFields, strSource, arrRooms, strDNC, strManager, objManager
    Dim objFSO, objFil, strBuffer, dicExceptions

'--> Initialize variables
    strFields = "manager,postalCode,st,l,roomNumber,streetAddress,Department,Company,physicalDeliveryOfficeName,mobile,TelephoneNumber,mail,title,givenName,SN,samAccountName"

'--> Turn error handling off
On Error Resume Next

'--> Read a list of exceptions in from a text file
    Set dicExceptions = CreateObject("Scripting.Dictionary")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If objFSO.FileExists(EXCEPTION_FILE) Then
        Set objFil = objFSO.OpenTextFile(EXCEPTION_FILE)
        Do Until objFil.AtEndOfStream
            strBuffer = LCase(objFil.ReadLine)
            dicExceptions.Add strBuffer, strBuffer
        Loop
        objFil.Close
        Set objFil = Nothing
    End If
    Set objFSO = Nothing

'--> Create the Excel spreadsheet and write a header to it
    Set excApp = CreateObject("Excel.Application")
    Set excWkb = excApp.Workbooks.Add
    Set excWks = excWkb.Worksheets(1)
    With excWks
        .Cells(1, 1) = "Account"
        .Cells(1, 2) = "Last Name"
        .Cells(1, 3) = "First Name"
        .Cells(1, 4) = "Title"
        .Cells(1, 5) = "Email"
        .Cells(1, 6) = "Telephone"
        .Cells(1, 7) = "Mobile"
        .Cells(1, 8) = "Office"
        .Cells(1, 9) = "Company"
        .Cells(1, 10) = "Department"
        .Cells(1, 11) = "Street"
        .Cells(1, 12) = "Room"
        .Cells(1, 13) = "City"
        .Cells(1, 14) = "State"
        .Cells(1, 15) = "Zip"
        .Cells(1, 16) = "Manager"
    End With
    
'--> Connect to and read AD
    Set objADRDSE = GetObject("LDAP://RootDSE")
    strDNC = objADRDSE.Get("defaultnamingcontext")
    strSource = "'LDAP://" & strDNC & "'"
    Set adoCon = CreateObject("ADODB.Connection")
    adoCon.CursorLocation = 3
    adoCon.Provider = "ADsDSOObject"
    adoCon.Open "ADSI"
    Set adoCmd = CreateObject("ADODB.Command")
    adoCmd.ActiveConnection = adoCon
    adoCmd.CommandText = "SELECT " & strFields & " FROM " & strSource & " Where objectClass='user' AND objectCategory='Person' ORDER BY samAccountName"
    adoCmd.Properties("Size Limit") = 5000
    adoCmd.Properties("Page Size") = 100
    adoCmd.Properties("Timeout") = 30
    adoCmd.Properties("Cache Results") = False
    Set adoRS = adoCmd.Execute()
    If Not adoRS.EOF Then
        intRow = 2
        Do While Not adoRS.EOF
            With adoRS
                For Each adoField In .Fields
                    Select Case LCase(adoField.Name)
                        Case "samaccountname"
                            excWks.Cells(intRow, 1) = adoField.Value
                        Case "sn"
                            excWks.Cells(intRow, 2) = adoField.Value
                        Case "givenname"
                            excWks.Cells(intRow, 3) = adoField.Value
                        Case "title"
                            excWks.Cells(intRow, 4) = adoField.Value
                        Case "mail"
                            excWks.Cells(intRow, 5) = adoField.Value
                        Case "telephonenumber"
                            excWks.Cells(intRow, 6) = adoField.Value
                        Case "mobile"
                            excWks.Cells(intRow, 7) = adoField.Value
                        Case "physicaldeliveryofficename"
                            excWks.Cells(intRow, 8) = adoField.Value
                        Case "company"
                            excWks.Cells(intRow, 9) = adoField.Value
                        Case "department"
                            excWks.Cells(intRow, 10) = adoField.Value
                        Case "streetaddress"
                            excWks.Cells(intRow, 11) = adoField.Value
                        Case "roomnumber"
                            If Not IsNull(adoField.Value) Then
                                arrRooms = adoField.Value
                                excWks.Cells(intRow, 12) = arrRooms(0)
                            End If
                        Case "l"
                            excWks.Cells(intRow, 13) = adoField.Value
                        Case "st"
                            excWks.Cells(intRow, 14) = adoField.Value
                        Case "postalcode"
                            excWks.Cells(intRow, 15) = adoField.Value
                        Case "manager"
                            If Not IsNull(adoField.Value) Then
                                Set objManager = GetObject("LDAP://" & adoField.Value)
                                strManager = objManager.DisplayName
                            Else
                                strManager = ""
                            End If
                            excWks.Cells(intRow, 16) = strManager
                            Set objManager = Nothing
                            strManager = ""
                    End Select
                Next
                intRow = intRow + 1
                .MoveNext
            End With
        Loop
    End If

'--> Clean up AD objects
    adoRS.Close
    Set adoRS = Nothing
    adoCon.Close
    Set adoCon = Nothing

'--> Connect to Outlook
    Set olkApp = CreateObject("Outlook.Application")
    Set olkSes = olkApp.GetNamespace("MAPI")
    olkSes.Logon olkApp.DefaultProfileName
    Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Items
    
'--> Read the contacts downloaded from AD and add, update, or delete contacts from Outlook
    For intRow = 2 To excWks.UsedRange.rows.Count
        If excWks.Cells(intRow, 2).Value = "" Or excWks.Cells(intRow, 3).Value = "" Or excWks.Cells(intRow, 5).Value = "" Then
            'The first anem, last name, or email address is empty.  Skip the entry.
        Else
            If dicExceptions.Exists(LCase(excWks.Cells(intRow, 5).Value)) Then
                'The address is in the exception list, so skip it
            Else
                Set olkCon = olkFld.Find("[User1] = '" & Replace(excWks.Cells(intRow, 1).Value, "'", "''") & "'")
                If TypeName(olkCon) = "Nothing" Then
                    Set olkCon = olkFld.Add
                    olkCon.User1 = excWks.Cells(intRow, 1).Value
                End If
                With olkCon
                    .LastName = excWks.Cells(intRow, 2).Value
                    .FirstName = excWks.Cells(intRow, 3).Value
                    .JobTitle = excWks.Cells(intRow, 4).Value
                    .Email1Address = excWks.Cells(intRow, 5).Value
                    .BusinessTelephoneNumber = excWks.Cells(intRow, 6).Value
                    .MobileTelephoneNumber = excWks.Cells(intRow, 7).Value
                    .OfficeLocation = excWks.Cells(intRow, 8).Value
                    .CompanyName = excWks.Cells(intRow, 9).Value
                    .Department = excWks.Cells(intRow, 10).Value
                    .BusinessAddressStreet = excWks.Cells(intRow, 11).Value
                    .BusinessAddressCity = excWks.Cells(intRow, 13).Value
                    .BusinessAddressState = excWks.Cells(intRow, 14).Value
                    .BusinessAddressPostalCode = excWks.Cells(intRow, 15).Value
                    .ManagerName = excWks.Cells(intRow, 16).Value
                    .NickName = .LastName & ", " & .FirstName
                    .Categories = "AutoUpdate"
                    .Save
                End With
                Set olkCon = Nothing
            End If
        End If
    Next

'--> Disconnect from Outlook
    olkSes.Logoff
    Set olkFld = Nothing
    Set olkSes = Nothing
    Set olkApp = Nothing

'--> Save and close the spreadsheet, then close Excel
    excWkb.Close False
    Set excWks = Nothing
    Set excWkb = Nothing
    excApp.Quit
    Set excApp = Nothing
    
'--> Kill other objects
    Set dicExceptions = Nothing
    
'--> Notify the user that the script has finished then terminate processing
    WScript.Quit

Open in new window

DarrenEley

ASKER

Hiya.. Excellent!!! Thank you. Works perfect on my outlook and Android phone, I have asked the Iphone user if he can check his contacts.

Thank you. Will let you know how it goes with the Iphone details etc.

Regards

Darren

David Lee

You're welcome!