Solved

Update Local outlook contacts from Exchange 2010 GAL automaticlly

Posted on 2014-03-10
14
484 Views
Last Modified: 2014-03-21
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
0
Comment
Question by:DarrenEley
  • 7
  • 6
14 Comments
 
LVL 38

Expert Comment

by:Adam Brown
ID: 39918405
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?
0
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 39920410
Hi, Darren.

See this question where another person asks for the same capability.
0
 

Author Closing Comment

by:DarrenEley
ID: 39921275
Thank you, I failed to see this one when I was having a look around.

Thank you.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 39921575
You're welcome.  Give me a shout if you need any modifications to the script.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 39944830
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

0
 

Author Comment

by:DarrenEley
ID: 39944859
Hiya, Thank you so much, is there anything in there for adding exceptions?

Thanks in advance.

Regards

Darren
0
 
LVL 76

Expert Comment

by:David Lee
ID: 39944864
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?
0
Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

 

Author Comment

by:DarrenEley
ID: 39944869
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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 39944903
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

0
 

Author Comment

by:DarrenEley
ID: 39944915
Thank you so very much, I will give it a go now and see how it goes.

Regards

Darren
0
 

Author Comment

by:DarrenEley
ID: 39944947
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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 39945038
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

0
 

Author Comment

by:DarrenEley
ID: 39945076
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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 39945112
You're welcome!
0

Featured Post

Why spend so long doing email signature updates?

Do you spend loads of your time carrying out email signature updates? Not very interesting are they? Don’t let signature updates get you down. Let Exclaimer Cloud - Signatures for Office 365 make managing email signatures a breeze.

Join & Write a Comment

Not sure what the best email signature size is? Are you worried about email signature image size? Follow this best practice guide.
Marketers need statistics and metrics like everybody else needs oxygen. In this article we explain how to enable marketing campaign statistics for Microsoft Exchange mail.
In this video we show how to create an email address policy in Exchange 2013. We show this process by using the Exchange Admin Center. Log into Exchange Admin Center.:  First we need to log into the Exchange Admin Center. Navigate to the Mail Flow…
how to add IIS SMTP to handle application/Scanner relays into office 365.

747 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now