Link to home
Start Free TrialLog in
Avatar of ITPro44
ITPro44Flag for United States of America

asked on

Script Outlook to Update GAL- CONTINUED

My previous question has been deleted so I've created a new one in hopes that BlueDevilFan can further assist me with a script.  I've also attached the deleted question as a PDF document so it can be reviewed.

To summarize, BlueDevilFan helped develop a script that will update a contact list in outlook.  There were two solutions.  

1. AD Option
- This solution pulled in contacts from AD
- As it was left, this option just pulled contacts into the users main contacts list, it did not create a separate contacts list.
- The improvement needed for this solution is pull from a specified distribution group and sync these contacts to a separate contact list.  The name of the distribution group and contacts list should be able to be changed.  If users are removed from the source distribution group, they should be removed from the contact list in outlook.  If users info is updated or new users are added to the DG, the contacts should be updated and added.


2. GAL Option
- This pulled contacts from the GAL and attempted to pull them from the Offline Address Book and importing them to a new contact list within outlook called "Company Contacts".  
- This solution bogged down outlook making it unusable during this import.  
- For this to work, it would have to reliably pull from the OAB and not bog down outlook.

If we can get the AD option to work first that would be ideal.  I think this will be the easiest option to get working as well.
Experts-Exchange-Question---Script-O.pdf
Avatar of David Lee
David Lee
Flag of United States of America image

Hi, ITPro44.

Do you still have the last bit of code we were using?  It's in the PDF file but I'm unable to copy and paste it out.  If you don't have it, then I'll type it up again.
Avatar of ITPro44

ASKER

Here is the Code for the AD Solution.
'--> 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("[Nickname] = '" & Replace(excWks.cells(intRow,1).value, "'", "''") & "'")
			If TypeName(olkCon) = "Nothing" Then
				Set olkCon = olkFld.Add
				olkCon.nickname = 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
		        .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

What do "distribution group" and "separate contacts list" mean in this context?  Does the former refer to an actual distribution group in Active Directory?  Does the latter refer to a separate contacts folder in Outlook?
Avatar of ITPro44

ASKER

Yes, in the script above, it filters out the users it's going to sync based on certain criteria.  Instead of that, I'd like to have all users and contacts within a distribution group in AD sync.

Separate contacts list does mean separate contacts folder in outlook.   I've attached a picture to show.  It contains a separate contacts folder / separate contacts list called "Company Contacts".
company-contacts.jpg
Please clarify what "distribution group" means in this context.  Are we talking an actual distribution group (aka a distribution list), an OU that contains the entries you want to copy, or something else?  I need to know because the code varies depending on what we're talking about.  For example, if we're talking about an actual distribution group, then the code needs to read the group, retrieve each member of the group, check to see if the member is an account or a nested group and then act accordingly.  If instead we're talking about an OU, then the code is very different.  I don't want to spend time writing the wrong code and then have to do it over.
Avatar of ITPro44

ASKER

Distrbution group means distribution group in active directory.
I'm nearly finished with the revised script.  How should it handle groups in the distribution list, or will there be any?
Avatar of ITPro44

ASKER

Great!!  Good question.  If there are groups within the distribution group it should add the group itself, not the members of the group individually.
Ok, please try this version.  This version syncs the contents of the specified list to an Outlook folder.  For each entry in the list the code checks to see if it is for a user or a group.  If it's a user, them the code creates an Outlook contact for that user.  If it is a group, then the code creates an Outlook distribution list and adds the group's members to it.  It only handles top-level groups.  It does not create a group for every sub-group in the group.  It does add sub-groups as members, but it doesn't copy the group to Outlook.  Pay attention to the comments at the top of the code (i.e. in the Constants section).  

'--> Create some constants
        'On the next line edit the LDAP path to your Active Directory
	Const LDAP_STRING = "LDAP://company.com/,DC=company,DC=com"
        'On the next line edit the path to the contacts folder in Outlook the list is to be synced to
	Const CONTACT_FOLDER_PATH = "john.doe@company.com\Contacts\Company Contacts"
        'On the next line edit the email address of the list to sync from
	Const DISTRIBUTION_GROUP_ADDRESS = "somelist@company.com"

'--> Create some variables
	Dim objUsr, objGrp, olkApp, olkSes, olkFld, olkCon, adoCon, adoRec, arrRooms, strRoom, strManager, objAct, objManager, strClass, strBuf, arrTmp, varTmp, arrItm, lngCnt
	
'--> Initialize some variables
	Set objUsr = CreateObject("Scripting.Dictionary")
	Set objGrp = CreateObject("Scripting.Dictionary")

'--> Turn error handling off
	On Error Resume Next
	
'--> Connect to and read AD
	Set adoCon = CreateObject("ADODB.Connection")
	With adoCon
		.CursorLocation = 3
		.Provider = "ADsDSOObject"
		.Open "ADSI"
	End With
	Set adoRec = adoCon.Execute("SELECT adsPath,member FROM '" &  LDAP_STRING & "' WHERE objectClass='group' AND mail='" & DISTRIBUTION_GROUP_ADDRESS & "'")
	If Not IsEmpty(adoRec) Then
		'--> Read AD
		While Not adoRec.EOF
		    arrMembers = adoRec.Fields("Member")
		    For Each varMember In arrMembers
				Set objAct = GetObject("LDAP://" & varMember)
				strClass = Join(objAct.objectClass, ",")
				If InStr(1, strClass, "user") > 0 Then
					If Not IsNull(objAct.roomNumber) Then
						arrRooms = objAct.roomNumber
						strRoom = arrRooms(0)
					Else
						strRoom = ""
					End If
					If Not IsNull(objAct.manager) Then
						Set objManager = GetObject("LDAP://" &  objAct.manager)
						strManager = objManager.DisplayName
					Else
						strManager = ""
					End If
					Set objManager = Nothing
					strBuf = objAct.samAccountName & "|"
					strBuf = strBuf & objAct.sn & "|"
					strBuf = strBuf & objAct.givenName & "|"
					strBuf = strBuf & objAct.title & "|"
					strBuf = strBuf & objAct.mail & "|"
					strBuf = strBuf & objAct.telephoneNumber & "|"
					strBuf = strBuf & objAct.mobile & "|"
					strBuf = strBuf & objAct.physicalDeliveryOfficeName & "|"
					strBuf = strBuf & objAct.company & "|"
					strBuf = strBuf & objAct.department & "|"
					strBuf = strBuf & objAct.streetAddress & "|"
					strBuf = strBuf & strRoom & "|"
					strBuf = strBuf & objAct.l & "|"
					strBuf = strBuf & objAct.st & "|"
					strBuf = strBuf & objAct.postalCode & "|"
					strBuf = strBuf & strManager & "|"
					objUsr.Add objAct.samAccountName, strBuf
				Else
					If InStr(1, strClass, "group") > 0 Then
						objGrp.add objAct.samAccountName, objAct.ADsPath
					End If
				End If
			Next
	    	adoRec.MoveNext
		Wend
		
		'--> Connect to Outlook
		Set olkApp = CreateObject("Outlook.Application")
		Set olkSes = olkApp.GetNamespace("MAPI")
		olkSes.Logon olkApp.DefaultProfileName
		Set olkFld = OpenOutlookFolder(CONTACT_FOLDER_PATH)
		
		'--> Delete the items from the Outlook folder
		For lngCnt = olkFld.Items.Count To 1 Step -1
			olkFld.Items.Remove lngCnt
		Next
		
		'--> Read the contacts downloaded from AD and add them to Outlook
		arrTmp = objUsr.Items
		For Each varTmp In arrTmp
			arrItm = Split(varTmp, "|")
			If (arrItm(1) = "") Or (arrItm(2) = "") Or (arrItm(4) = "") Then
			Else
				Set olkCon = olkFld.Items.Add
				olkCon.nickname = arrItm(0)
				With olkCon
					.LastName = arrItm(1)
					.Firstname = arrItm(2)
					.JobTitle = arrItm(3)
			        .Email1Address = arrItm(4)
			        .BusinessTelephoneNumber = arrItm(5)
			        .MobileTelephoneNumber = arrItm(6)
			        .OfficeLocation = arrItm(7)
			        .CompanyName = arrItm(8)
			        .Department = arrItm(9)
			        .BusinessAddressStreet = arrItm(10)
			        .BusinessAddressCity = arrItm(12)
			        .BusinessAddressState = arrItm(13)
			        .BusinessAddressPostalCode = arrItm(14)
			        .ManagerName = arrItm(15)
			        .Categories = "AutoUpdate"
			        .Save
				End With
				Set olkCon = Nothing
			End If
		Next
		
		'--> Read the groups downloaded from AD and add them to Outlook
		arrTmp = objGrp.Items
		For Each varTmp In arrTmp
			CopyGroup varTmp
		Next
	
		'--> Disconnect from Outlook
		olkSes.Logoff
		Set olkFld = Nothing
		Set olkSes = Nothing
		Set olkApp = Nothing
	End If
	
'--> Clean up AD objects
	adoRec.Close
	Set adoRec = Nothing
	adoCon.Close
	Set adoCon = Nothing

'--> Clean up other objects
	Set objUsr = Nothing
	Set objGrp = Nothing
	Set objAct = Nothing
	
'--> Notify the user that the script has finished then terminate processing
	WScript.Quit
	
Function OpenOutlookFolder(strFolderPath)
	Dim arrFolders, varFolder, bolBeyondRoot
	On Error Resume Next
	If strFolderPath = "" Then
		Set OpenOutlookFolder = Nothing
	Else
		Do While Left(strFolderPath, 1) = "\"
			strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
		Loop
		arrFolders = Split(strFolderPath, "\")
		For Each varFolder In arrFolders
			Select Case bolBeyondRoot
				Case False
					Set OpenOutlookFolder = olkSes.Folders(varFolder)
					bolBeyondRoot = True
				Case True
				Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
			End Select
			If Err.Number <> 0 Then
				Set OpenOutlookFolder = Nothing
				Exit For
			End If
		Next
	End If
	On Error GoTo 0
End Function

Sub CopyGroup(varPath)
	Const olDistributionListItem = 7
	Dim objGrp, olkGrp, olkRec, varMem, objAct
	Set objGrp = GetObject(varPath)
	Set olkGrp = olkFld.Items.Add(olDistributionListItem)
	olkGrp.Subject = objGrp.displayName
	'Set olkGrp = olkApp.CreateItem(olDistributionListItem)
	For Each varMem In objGrp.member
		Set objAct = GetObject("LDAP://" & varMem)
		If objAct.mail <> "" Then
			Set olkRec = olkSes.CreateRecipient(objAct.mail)
			olkRec.Resolve
			If olkRec.Resolved Then
				olkGrp.AddMember olkRec
			End If
		End If
	Next
	olkGrp.Save
	Set objGrp = Nothing
	Set olkGrp = Nothing
	Set olkRec = Nothing
	Set objAct = Nothing	
End Sub

Open in new window

Avatar of ITPro44

ASKER

thanks BlueDevil!  I gave it a go and can't seem to get it to run.  In the original script the LDAP path was set to "LDAP://RootDSE" so it didn't need to be customized to our domain.  Can that be used here?  Also, the previous script did also not need to call out the contact folder path for a specific user.  Can it just default to the logged on user?

This is what I changed in the script:

   
        'On the next line edit the LDAP path to your Active Directory
	Const LDAP_STRING = "LDAP://localdomainname.local/,DC=localdomainname,DC=local"
        'On the next line edit the path to the contacts folder in Outlook the list is to be synced to
	Const CONTACT_FOLDER_PATH = "username@publicdomain.com\Contacts\Company Contacts"
        'On the next line edit the email address of the list to sync from
	Const DISTRIBUTION_GROUP_ADDRESS = "All@publicdomain.com"

Open in new window

I made those changes. Please try this version.

'--> Create some constants
	'On the next line edit the email address of the list to sync from
	Const DISTRIBUTION_GROUP_ADDRESS = "somelist@company.com"
	Const SCRIPT_NAME = "List Sychronization (v1.0)"
	Const olFolderContacts = 10

'--> Create some variables
	Dim objUsr, objGrp, objAct, objManager, objADRDSE 
	Dim olkApp, olkSes, olkFld, olkCon
	Dim adoCon, adoRec
	Dim arrRooms, strRoom, strManager, strClass, strBuf, arrTmp, varTmp, arrItm, lngCnt, strSource, strDNC
	
'--> Initialize some variables
	Set objUsr = CreateObject("Scripting.Dictionary")
	Set objGrp = CreateObject("Scripting.Dictionary")

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

'--> get the AD root
	Set objADRDSE = GetObject("LDAP://RootDSE")
	strDNC = objADRDSE.Get("defaultnamingcontext")
	strSource = "'LDAP://" & strDNC & "'"
	
'--> Connect to and read AD
	Set adoCon = CreateObject("ADODB.Connection")
	With adoCon
		.CursorLocation = 3
		.Provider = "ADsDSOObject"
		.Open "ADSI"
	End With
	Set adoRec = adoCon.Execute("SELECT adsPath,member FROM '" &  strSource & "' WHERE objectClass='group' AND mail='" & DISTRIBUTION_GROUP_ADDRESS & "'")
	If Not IsEmpty(adoRec) Then
		'--> Read AD
		While Not adoRec.EOF
		    arrMembers = adoRec.Fields("Member")
		    For Each varMember In arrMembers
				Set objAct = GetObject("LDAP://" & varMember)
				strClass = Join(objAct.objectClass, ",")
				If InStr(1, strClass, "user") > 0 Then
					If Not IsNull(objAct.roomNumber) Then
						arrRooms = objAct.roomNumber
						strRoom = arrRooms(0)
					Else
						strRoom = ""
					End If
					If Not IsNull(objAct.manager) Then
						Set objManager = GetObject("LDAP://" &  objAct.manager)
						strManager = objManager.DisplayName
					Else
						strManager = ""
					End If
					Set objManager = Nothing
					strBuf = objAct.samAccountName & "|"
					strBuf = strBuf & objAct.sn & "|"
					strBuf = strBuf & objAct.givenName & "|"
					strBuf = strBuf & objAct.title & "|"
					strBuf = strBuf & objAct.mail & "|"
					strBuf = strBuf & objAct.telephoneNumber & "|"
					strBuf = strBuf & objAct.mobile & "|"
					strBuf = strBuf & objAct.physicalDeliveryOfficeName & "|"
					strBuf = strBuf & objAct.company & "|"
					strBuf = strBuf & objAct.department & "|"
					strBuf = strBuf & objAct.streetAddress & "|"
					strBuf = strBuf & strRoom & "|"
					strBuf = strBuf & objAct.l & "|"
					strBuf = strBuf & objAct.st & "|"
					strBuf = strBuf & objAct.postalCode & "|"
					strBuf = strBuf & strManager & "|"
					objUsr.Add objAct.samAccountName, strBuf
				Else
					If InStr(1, strClass, "group") > 0 Then
						objGrp.add objAct.samAccountName, objAct.ADsPath
					End If
				End If
			Next
	    	adoRec.MoveNext
		Wend
		
		'--> Connect to Outlook
		Set olkApp = CreateObject("Outlook.Application")
		Set olkSes = olkApp.GetNamespace("MAPI")
		olkSes.Logon olkApp.DefaultProfileName
		Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Folders("Company Contacts")
		
		'--> Delete the items from the Outlook folder
		For lngCnt = olkFld.Items.Count To 1 Step -1
			olkFld.Items.Remove lngCnt
		Next
		
		'--> Read the contacts downloaded from AD and add them to Outlook
		arrTmp = objUsr.Items
		For Each varTmp In arrTmp
			arrItm = Split(varTmp, "|")
			If (arrItm(1) = "") Or (arrItm(2) = "") Or (arrItm(4) = "") Then
			Else
				Set olkCon = olkFld.Items.Add
				olkCon.nickname = arrItm(0)
				With olkCon
					.LastName = arrItm(1)
					.Firstname = arrItm(2)
					.JobTitle = arrItm(3)
			        .Email1Address = arrItm(4)
			        .BusinessTelephoneNumber = arrItm(5)
			        .MobileTelephoneNumber = arrItm(6)
			        .OfficeLocation = arrItm(7)
			        .CompanyName = arrItm(8)
			        .Department = arrItm(9)
			        .BusinessAddressStreet = arrItm(10)
			        .BusinessAddressCity = arrItm(12)
			        .BusinessAddressState = arrItm(13)
			        .BusinessAddressPostalCode = arrItm(14)
			        .ManagerName = arrItm(15)
			        .Categories = "AutoUpdate"
			        .Save
				End With
				Set olkCon = Nothing
			End If
		Next
		
		'--> Read the groups downloaded from AD and add them to Outlook
		arrTmp = objGrp.Items
		For Each varTmp In arrTmp
			CopyGroup varTmp
		Next
	
		'--> Disconnect from Outlook
		olkSes.Logoff
		Set olkFld = Nothing
		Set olkSes = Nothing
		Set olkApp = Nothing
	End If
	
'--> Clean up AD objects
	adoRec.Close
	Set adoRec = Nothing
	adoCon.Close
	Set adoCon = Nothing

'--> Clean up other objects
	Set objUsr = Nothing
	Set objGrp = Nothing
	Set objAct = Nothing
	Set objADRDSE = Nothing
	
'--> Notify the user that the script has finished then terminate processing
	MsgBox "Synchronization complete.", vbInformation+vbOKOnly, SCRIPT_NAME
	WScript.Quit

Sub CopyGroup(varPath)
	Const olDistributionListItem = 7
	Dim objGrp, olkGrp, olkRec, varMem, objAct
	Set objGrp = GetObject(varPath)
	Set olkGrp = olkFld.Items.Add(olDistributionListItem)
	olkGrp.Subject = objGrp.displayName
	'Set olkGrp = olkApp.CreateItem(olDistributionListItem)
	For Each varMem In objGrp.member
		Set objAct = GetObject("LDAP://" & varMem)
		If objAct.mail <> "" Then
			Set olkRec = olkSes.CreateRecipient(objAct.mail)
			olkRec.Resolve
			If olkRec.Resolved Then
				olkGrp.AddMember olkRec
			End If
		End If
	Next
	olkGrp.Save
	Set objGrp = Nothing
	Set olkGrp = Nothing
	Set olkRec = Nothing
	Set objAct = Nothing	
End Sub                                      

Open in new window

Avatar of ITPro44

ASKER

ok, so it runs and says "Synchronization Complete" but no contacts are synced.  I also do not see where i can rename the contacts folder where these contacts will be placed.  It appears that you removed the path for to the contacts folder along with the ability to specify the name of the contacts folder.  Please advise.
Edit line 84.  Change "Company Contacts" to the name of the folder you want to sync to.  That folder must be under the default Contacts folder.
Avatar of ITPro44

ASKER

I manually created a contacts folder called "Company Contacts" but it still doesn't work for me.  I don't know why.  That said, if the contacts folder doesn't exist, can have the script create it?
Did you create the "Company Contacts" folder under your Contacts folder?  If not, then that's the problem.
Avatar of ITPro44

ASKER

Yes I did.
Yes, I can add code to create the "Company Contacts" folder if it doesn't exist.  However, since the folder does exist and it is under your Contacts folder, the code should be working now.  It works perfectly for me.  Try commenting-out or removing line 18.  Run it again and let me know if you get any errors.  If you do, I need the complete wording of the error.
Avatar of ITPro44

ASKER

Screen shot of the error is attached.
User generated image
Please try this version.

'--> Create some constants
	'On the next line edit the email address of the list to sync from
	Const DISTRIBUTION_GROUP_ADDRESS = "somelist@company.com"
	Const SCRIPT_NAME = "List Sychronization (v1.0)"
	Const olFolderContacts = 10

'--> Create some variables
	Dim objUsr, objGrp, objAct, objManager, objADRDSE 
	Dim olkApp, olkSes, olkFld, olkCon
	Dim adoCon, adoRec
	Dim arrRooms, strRoom, strManager, strClass, strBuf, arrTmp, varTmp, arrItm, lngCnt, strSource, strDNC
	
'--> Initialize some variables
	Set objUsr = CreateObject("Scripting.Dictionary")
	Set objGrp = CreateObject("Scripting.Dictionary")

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

'--> get the AD root
	Set objADRDSE = GetObject("LDAP://RootDSE")
	strDNC = objADRDSE.Get("defaultnamingcontext")
	strSource = "LDAP://" & strDNC
	
'--> Connect to and read AD
	Set adoCon = CreateObject("ADODB.Connection")
	With adoCon
		.CursorLocation = 3
		.Provider = "ADsDSOObject"
		.Open "ADSI"
	End With
	Set adoRec = adoCon.Execute("SELECT adsPath,member FROM '" &  strSource & "' WHERE objectClass='group' AND mail='" & DISTRIBUTION_GROUP_ADDRESS & "'")
	If Not IsEmpty(adoRec) Then
		'--> Read AD
		While Not adoRec.EOF
		    arrMembers = adoRec.Fields("Member")
		    For Each varMember In arrMembers
				Set objAct = GetObject("LDAP://" & varMember)
				strClass = Join(objAct.objectClass, ",")
				If InStr(1, strClass, "user") > 0 Then
					If Not IsNull(objAct.roomNumber) Then
						arrRooms = objAct.roomNumber
						strRoom = arrRooms(0)
					Else
						strRoom = ""
					End If
					If Not IsNull(objAct.manager) Then
						Set objManager = GetObject("LDAP://" &  objAct.manager)
						strManager = objManager.DisplayName
					Else
						strManager = ""
					End If
					Set objManager = Nothing
					strBuf = objAct.samAccountName & "|"
					strBuf = strBuf & objAct.sn & "|"
					strBuf = strBuf & objAct.givenName & "|"
					strBuf = strBuf & objAct.title & "|"
					strBuf = strBuf & objAct.mail & "|"
					strBuf = strBuf & objAct.telephoneNumber & "|"
					strBuf = strBuf & objAct.mobile & "|"
					strBuf = strBuf & objAct.physicalDeliveryOfficeName & "|"
					strBuf = strBuf & objAct.company & "|"
					strBuf = strBuf & objAct.department & "|"
					strBuf = strBuf & objAct.streetAddress & "|"
					strBuf = strBuf & strRoom & "|"
					strBuf = strBuf & objAct.l & "|"
					strBuf = strBuf & objAct.st & "|"
					strBuf = strBuf & objAct.postalCode & "|"
					strBuf = strBuf & strManager & "|"
					objUsr.Add objAct.samAccountName, strBuf
				Else
					If InStr(1, strClass, "group") > 0 Then
						objGrp.add objAct.samAccountName, objAct.ADsPath
					End If
				End If
			Next
	    	adoRec.MoveNext
		Wend
		
		'--> Connect to Outlook
		Set olkApp = CreateObject("Outlook.Application")
		Set olkSes = olkApp.GetNamespace("MAPI")
		olkSes.Logon olkApp.DefaultProfileName
		Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Folders("Company Contacts")
		
		'--> Delete the items from the Outlook folder
		For lngCnt = olkFld.Items.Count To 1 Step -1
			olkFld.Items.Remove lngCnt
		Next
		
		'--> Read the contacts downloaded from AD and add them to Outlook
		arrTmp = objUsr.Items
		For Each varTmp In arrTmp
			arrItm = Split(varTmp, "|")
			If (arrItm(1) = "") Or (arrItm(2) = "") Or (arrItm(4) = "") Then
			Else
				Set olkCon = olkFld.Items.Add
				olkCon.nickname = arrItm(0)
				With olkCon
					.LastName = arrItm(1)
					.Firstname = arrItm(2)
					.JobTitle = arrItm(3)
			        .Email1Address = arrItm(4)
			        .BusinessTelephoneNumber = arrItm(5)
			        .MobileTelephoneNumber = arrItm(6)
			        .OfficeLocation = arrItm(7)
			        .CompanyName = arrItm(8)
			        .Department = arrItm(9)
			        .BusinessAddressStreet = arrItm(10)
			        .BusinessAddressCity = arrItm(12)
			        .BusinessAddressState = arrItm(13)
			        .BusinessAddressPostalCode = arrItm(14)
			        .ManagerName = arrItm(15)
			        .Categories = "AutoUpdate"
			        .Save
				End With
				Set olkCon = Nothing
			End If
		Next
		
		'--> Read the groups downloaded from AD and add them to Outlook
		arrTmp = objGrp.Items
		For Each varTmp In arrTmp
			CopyGroup varTmp
		Next
	
		'--> Disconnect from Outlook
		olkSes.Logoff
		Set olkFld = Nothing
		Set olkSes = Nothing
		Set olkApp = Nothing
	End If
	
'--> Clean up AD objects
	adoRec.Close
	Set adoRec = Nothing
	adoCon.Close
	Set adoCon = Nothing

'--> Clean up other objects
	Set objUsr = Nothing
	Set objGrp = Nothing
	Set objAct = Nothing
	Set objADRDSE = Nothing
	
'--> Notify the user that the script has finished then terminate processing
	MsgBox "Synchronization complete.", vbInformation+vbOKOnly, SCRIPT_NAME
	WScript.Quit

Sub CopyGroup(varPath)
	Const olDistributionListItem = 7
	Dim objGrp, olkGrp, olkRec, varMem, objAct
	Set objGrp = GetObject(varPath)
	Set olkGrp = olkFld.Items.Add(olDistributionListItem)
	olkGrp.Subject = objGrp.displayName
	'Set olkGrp = olkApp.CreateItem(olDistributionListItem)
	For Each varMem In objGrp.member
		Set objAct = GetObject("LDAP://" & varMem)
		If objAct.mail <> "" Then
			Set olkRec = olkSes.CreateRecipient(objAct.mail)
			olkRec.Resolve
			If olkRec.Resolved Then
				olkGrp.AddMember olkRec
			End If
		End If
	Next
	olkGrp.Save
	Set objGrp = Nothing
	Set olkGrp = Nothing
	Set olkRec = Nothing
	Set objAct = Nothing	
End Sub

Open in new window

Avatar of ITPro44

ASKER

Awesome!!  It works great!  Your awesome!  I have two additional requests:

1. Can you have it create the Contacts Folder if it does not exist?
2. Can you make the name for Contacts Folder as a variable and make the variable defined at the top of the script (like the Distribution Group) so it's easily seen.
This version incorporates both of those changes.

'--> Create some constants
	'On the next line edit the email address of the list to sync from
	Const DISTRIBUTION_GROUP_ADDRESS = "somelist@company.com"
	'On the next line edit the name of the Outlook folder to sync to
	Const TARGET_FOLDER_NAME = "Company Contacts"
	Const SCRIPT_NAME = "List Sychronization (v1.0)"
	Const olFolderContacts = 10

'--> Create some variables
	Dim objUsr, objGrp, objAct, objManager, objADRDSE 
	Dim olkApp, olkSes, olkFld, olkCon
	Dim adoCon, adoRec
	Dim arrRooms, strRoom, strManager, strClass, strBuf, arrTmp, varTmp, arrItm, lngCnt, strSource, strDNC
	
'--> Initialize some variables
	Set objUsr = CreateObject("Scripting.Dictionary")
	Set objGrp = CreateObject("Scripting.Dictionary")

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

'--> get the AD root
	Set objADRDSE = GetObject("LDAP://RootDSE")
	strDNC = objADRDSE.Get("defaultnamingcontext")
	strSource = "'LDAP://" & strDNC & "'"
	
'--> Connect to and read AD
	Set adoCon = CreateObject("ADODB.Connection")
	With adoCon
		.CursorLocation = 3
		.Provider = "ADsDSOObject"
		.Open "ADSI"
	End With
	Set adoRec = adoCon.Execute("SELECT adsPath,member FROM '" &  strSource & "' WHERE objectClass='group' AND mail='" & DISTRIBUTION_GROUP_ADDRESS & "'")
	If Not IsEmpty(adoRec) Then
		'--> Read AD
		While Not adoRec.EOF
		    arrMembers = adoRec.Fields("Member")
		    For Each varMember In arrMembers
				Set objAct = GetObject("LDAP://" & varMember)
				strClass = Join(objAct.objectClass, ",")
				If InStr(1, strClass, "user") > 0 Then
					If Not IsNull(objAct.roomNumber) Then
						arrRooms = objAct.roomNumber
						strRoom = arrRooms(0)
					Else
						strRoom = ""
					End If
					If Not IsNull(objAct.manager) Then
						Set objManager = GetObject("LDAP://" &  objAct.manager)
						strManager = objManager.DisplayName
					Else
						strManager = ""
					End If
					Set objManager = Nothing
					strBuf = objAct.samAccountName & "|"
					strBuf = strBuf & objAct.sn & "|"
					strBuf = strBuf & objAct.givenName & "|"
					strBuf = strBuf & objAct.title & "|"
					strBuf = strBuf & objAct.mail & "|"
					strBuf = strBuf & objAct.telephoneNumber & "|"
					strBuf = strBuf & objAct.mobile & "|"
					strBuf = strBuf & objAct.physicalDeliveryOfficeName & "|"
					strBuf = strBuf & objAct.company & "|"
					strBuf = strBuf & objAct.department & "|"
					strBuf = strBuf & objAct.streetAddress & "|"
					strBuf = strBuf & strRoom & "|"
					strBuf = strBuf & objAct.l & "|"
					strBuf = strBuf & objAct.st & "|"
					strBuf = strBuf & objAct.postalCode & "|"
					strBuf = strBuf & strManager & "|"
					objUsr.Add objAct.samAccountName, strBuf
				Else
					If InStr(1, strClass, "group") > 0 Then
						objGrp.add objAct.samAccountName, objAct.ADsPath
					End If
				End If
			Next
	    	adoRec.MoveNext
		Wend
		
		'--> Connect to Outlook
		Set olkApp = CreateObject("Outlook.Application")
		Set olkSes = olkApp.GetNamespace("MAPI")
		olkSes.Logon olkApp.DefaultProfileName
		Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Folders(TARGET_FOLDER_NAME)
		If IsEmpty(olkFld) Then
			Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Folders.Add(TARGET_FOLDER_NAME)
		End If
		
		'--> Delete the items from the Outlook folder
		For lngCnt = olkFld.Items.Count To 1 Step -1
			olkFld.Items.Remove lngCnt
		Next
		
		'--> Read the contacts downloaded from AD and add them to Outlook
		arrTmp = objUsr.Items
		For Each varTmp In arrTmp
			arrItm = Split(varTmp, "|")
			If (arrItm(1) = "") Or (arrItm(2) = "") Or (arrItm(4) = "") Then
			Else
				Set olkCon = olkFld.Items.Add
				olkCon.nickname = arrItm(0)
				With olkCon
					.LastName = arrItm(1)
					.Firstname = arrItm(2)
					.JobTitle = arrItm(3)
			        .Email1Address = arrItm(4)
			        .BusinessTelephoneNumber = arrItm(5)
			        .MobileTelephoneNumber = arrItm(6)
			        .OfficeLocation = arrItm(7)
			        .CompanyName = arrItm(8)
			        .Department = arrItm(9)
			        .BusinessAddressStreet = arrItm(10)
			        .BusinessAddressCity = arrItm(12)
			        .BusinessAddressState = arrItm(13)
			        .BusinessAddressPostalCode = arrItm(14)
			        .ManagerName = arrItm(15)
			        .Categories = "AutoUpdate"
			        .Save
				End With
				Set olkCon = Nothing
			End If
		Next
		
		'--> Read the groups downloaded from AD and add them to Outlook
		arrTmp = objGrp.Items
		For Each varTmp In arrTmp
			CopyGroup varTmp
		Next
	
		'--> Disconnect from Outlook
		olkSes.Logoff
		Set olkFld = Nothing
		Set olkSes = Nothing
		Set olkApp = Nothing
	End If
	
'--> Clean up AD objects
	adoRec.Close
	Set adoRec = Nothing
	adoCon.Close
	Set adoCon = Nothing

'--> Clean up other objects
	Set objUsr = Nothing
	Set objGrp = Nothing
	Set objAct = Nothing
	Set objADRDSE = Nothing
	
'--> Notify the user that the script has finished then terminate processing
	MsgBox "Synchronization complete.", vbInformation+vbOKOnly, SCRIPT_NAME
	WScript.Quit

Sub CopyGroup(varPath)
	Const olDistributionListItem = 7
	Dim objGrp, olkGrp, olkRec, varMem, objAct
	Set objGrp = GetObject(varPath)
	Set olkGrp = olkFld.Items.Add(olDistributionListItem)
	olkGrp.Subject = objGrp.displayName
	'Set olkGrp = olkApp.CreateItem(olDistributionListItem)
	For Each varMem In objGrp.member
		Set objAct = GetObject("LDAP://" & varMem)
		If objAct.mail <> "" Then
			Set olkRec = olkSes.CreateRecipient(objAct.mail)
			olkRec.Resolve
			If olkRec.Resolved Then
				olkGrp.AddMember olkRec
			End If
		End If
	Next
	olkGrp.Save
	Set objGrp = Nothing
	Set olkGrp = Nothing
	Set olkRec = Nothing
	Set objAct = Nothing	
End Sub                                      

Open in new window

Avatar of ITPro44

ASKER

I tried it, but got the follower error.
User generated image
Sorry, I made the last change to an earlier version, one before I fixed yesterday's problem.  This should do it.

'--> Create some constants
	'On the next line edit the email address of the list to sync from
	Const DISTRIBUTION_GROUP_ADDRESS = "somelist@company.com"
	'On the next line edit the name of the Outlook folder to sync to
	Const TARGET_FOLDER_NAME = "Company Contacts"
	Const SCRIPT_NAME = "List Sychronization (v1.0)"
	Const olFolderContacts = 10

'--> Create some variables
	Dim objUsr, objGrp, objAct, objManager, objADRDSE 
	Dim olkApp, olkSes, olkFld, olkCon
	Dim adoCon, adoRec
	Dim arrRooms, strRoom, strManager, strClass, strBuf, arrTmp, varTmp, arrItm, lngCnt, strSource, strDNC
	
'--> Initialize some variables
	Set objUsr = CreateObject("Scripting.Dictionary")
	Set objGrp = CreateObject("Scripting.Dictionary")

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

'--> get the AD root
	Set objADRDSE = GetObject("LDAP://RootDSE")
	strDNC = objADRDSE.Get("defaultnamingcontext")
	strSource = "LDAP://" & strDNC
	
'--> Connect to and read AD
	Set adoCon = CreateObject("ADODB.Connection")
	With adoCon
		.CursorLocation = 3
		.Provider = "ADsDSOObject"
		.Open "ADSI"
	End With
	Set adoRec = adoCon.Execute("SELECT adsPath,member FROM '" &  strSource & "' WHERE objectClass='group' AND mail='" & DISTRIBUTION_GROUP_ADDRESS & "'")
	If Not IsEmpty(adoRec) Then
		'--> Read AD
		While Not adoRec.EOF
		    arrMembers = adoRec.Fields("Member")
		    For Each varMember In arrMembers
				Set objAct = GetObject("LDAP://" & varMember)
				strClass = Join(objAct.objectClass, ",")
				If InStr(1, strClass, "user") > 0 Then
					If Not IsNull(objAct.roomNumber) Then
						arrRooms = objAct.roomNumber
						strRoom = arrRooms(0)
					Else
						strRoom = ""
					End If
					If Not IsNull(objAct.manager) Then
						Set objManager = GetObject("LDAP://" &  objAct.manager)
						strManager = objManager.DisplayName
					Else
						strManager = ""
					End If
					Set objManager = Nothing
					strBuf = objAct.samAccountName & "|"
					strBuf = strBuf & objAct.sn & "|"
					strBuf = strBuf & objAct.givenName & "|"
					strBuf = strBuf & objAct.title & "|"
					strBuf = strBuf & objAct.mail & "|"
					strBuf = strBuf & objAct.telephoneNumber & "|"
					strBuf = strBuf & objAct.mobile & "|"
					strBuf = strBuf & objAct.physicalDeliveryOfficeName & "|"
					strBuf = strBuf & objAct.company & "|"
					strBuf = strBuf & objAct.department & "|"
					strBuf = strBuf & objAct.streetAddress & "|"
					strBuf = strBuf & strRoom & "|"
					strBuf = strBuf & objAct.l & "|"
					strBuf = strBuf & objAct.st & "|"
					strBuf = strBuf & objAct.postalCode & "|"
					strBuf = strBuf & strManager & "|"
					objUsr.Add objAct.samAccountName, strBuf
				Else
					If InStr(1, strClass, "group") > 0 Then
						objGrp.add objAct.samAccountName, objAct.ADsPath
					End If
				End If
			Next
	    	adoRec.MoveNext
		Wend
		
		'--> Connect to Outlook
		Set olkApp = CreateObject("Outlook.Application")
		Set olkSes = olkApp.GetNamespace("MAPI")
		olkSes.Logon olkApp.DefaultProfileName
		Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Folders(TARGET_FOLDER_NAME)
		If IsEmpty(olkFld) Then
			Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Folders.Add(TARGET_FOLDER_NAME)
		End If
		
		'--> Delete the items from the Outlook folder
		For lngCnt = olkFld.Items.Count To 1 Step -1
			olkFld.Items.Remove lngCnt
		Next
		
		'--> Read the contacts downloaded from AD and add them to Outlook
		arrTmp = objUsr.Items
		For Each varTmp In arrTmp
			arrItm = Split(varTmp, "|")
			If (arrItm(1) = "") Or (arrItm(2) = "") Or (arrItm(4) = "") Then
			Else
				Set olkCon = olkFld.Items.Add
				olkCon.nickname = arrItm(0)
				With olkCon
					.LastName = arrItm(1)
					.Firstname = arrItm(2)
					.JobTitle = arrItm(3)
			        .Email1Address = arrItm(4)
			        .BusinessTelephoneNumber = arrItm(5)
			        .MobileTelephoneNumber = arrItm(6)
			        .OfficeLocation = arrItm(7)
			        .CompanyName = arrItm(8)
			        .Department = arrItm(9)
			        .BusinessAddressStreet = arrItm(10)
			        .BusinessAddressCity = arrItm(12)
			        .BusinessAddressState = arrItm(13)
			        .BusinessAddressPostalCode = arrItm(14)
			        .ManagerName = arrItm(15)
			        .Categories = "AutoUpdate"
			        .Save
				End With
				Set olkCon = Nothing
			End If
		Next
		
		'--> Read the groups downloaded from AD and add them to Outlook
		arrTmp = objGrp.Items
		For Each varTmp In arrTmp
			CopyGroup varTmp
		Next
	
		'--> Disconnect from Outlook
		olkSes.Logoff
		Set olkFld = Nothing
		Set olkSes = Nothing
		Set olkApp = Nothing
	End If
	
'--> Clean up AD objects
	adoRec.Close
	Set adoRec = Nothing
	adoCon.Close
	Set adoCon = Nothing

'--> Clean up other objects
	Set objUsr = Nothing
	Set objGrp = Nothing
	Set objAct = Nothing
	Set objADRDSE = Nothing
	
'--> Notify the user that the script has finished then terminate processing
	MsgBox "Synchronization complete.", vbInformation+vbOKOnly, SCRIPT_NAME
	WScript.Quit

Sub CopyGroup(varPath)
	Const olDistributionListItem = 7
	Dim objGrp, olkGrp, olkRec, varMem, objAct
	Set objGrp = GetObject(varPath)
	Set olkGrp = olkFld.Items.Add(olDistributionListItem)
	olkGrp.Subject = objGrp.displayName
	'Set olkGrp = olkApp.CreateItem(olDistributionListItem)
	For Each varMem In objGrp.member
		Set objAct = GetObject("LDAP://" & varMem)
		If objAct.mail <> "" Then
			Set olkRec = olkSes.CreateRecipient(objAct.mail)
			olkRec.Resolve
			If olkRec.Resolved Then
				olkGrp.AddMember olkRec
			End If
		End If
	Next
	olkGrp.Save
	Set objGrp = Nothing
	Set olkGrp = Nothing
	Set olkRec = Nothing
	Set objAct = Nothing	
End Sub

Open in new window

Avatar of ITPro44

ASKER

Right on!  It works!

That said, I just noticed that it is not syncing "contacts".  It's syncing all users fine, but we also need it to sync contacts within Active Directory as well.  Can you add this ability?
Try this.

'--> Create some constants
	'On the next line edit the email address of the list to sync from
	Const DISTRIBUTION_GROUP_ADDRESS = "somelist@company.com"
	'On the next line edit the name of the Outlook folder to sync to
	Const TARGET_FOLDER_NAME = "Company Contacts"
	Const SCRIPT_NAME = "List Sychronization (v1.0)"
	Const olFolderContacts = 10

'--> Create some variables
	Dim objUsr, objGrp, objAct, objManager, objADRDSE 
	Dim olkApp, olkSes, olkFld, olkCon
	Dim adoCon, adoRec
	Dim arrRooms, strRoom, strManager, strClass, strBuf, arrTmp, varTmp, arrItm, lngCnt, strSource, strDNC
	
'--> Initialize some variables
	Set objUsr = CreateObject("Scripting.Dictionary")
	Set objGrp = CreateObject("Scripting.Dictionary")

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

'--> get the AD root
	Set objADRDSE = GetObject("LDAP://RootDSE")
	strDNC = objADRDSE.Get("defaultnamingcontext")
	strSource = "LDAP://" & strDNC
	
'--> Connect to and read AD
	Set adoCon = CreateObject("ADODB.Connection")
	With adoCon
		.CursorLocation = 3
		.Provider = "ADsDSOObject"
		.Open "ADSI"
	End With
	Set adoRec = adoCon.Execute("SELECT adsPath,member FROM '" &  strSource & "' WHERE objectClass='group' AND mail='" & DISTRIBUTION_GROUP_ADDRESS & "'")
	If Not IsEmpty(adoRec) Then
		'--> Read AD
		While Not adoRec.EOF
		    arrMembers = adoRec.Fields("Member")
		    For Each varMember In arrMembers
				Set objAct = GetObject("LDAP://" & varMember)
				strClass = Join(objAct.objectClass, ",")
				If (InStr(1, strClass, "user") > 0) Or (InStr(1, strClass, "contact") > 0) Then
					If Not IsNull(objAct.roomNumber) Then
						arrRooms = objAct.roomNumber
						strRoom = arrRooms(0)
					Else
						strRoom = ""
					End If
					If Not IsNull(objAct.manager) Then
						Set objManager = GetObject("LDAP://" &  objAct.manager)
						strManager = objManager.DisplayName
					Else
						strManager = ""
					End If
					Set objManager = Nothing
					strBuf = objAct.samAccountName & "|"
					strBuf = strBuf & objAct.sn & "|"
					strBuf = strBuf & objAct.givenName & "|"
					strBuf = strBuf & objAct.title & "|"
					strBuf = strBuf & objAct.mail & "|"
					strBuf = strBuf & objAct.telephoneNumber & "|"
					strBuf = strBuf & objAct.mobile & "|"
					strBuf = strBuf & objAct.physicalDeliveryOfficeName & "|"
					strBuf = strBuf & objAct.company & "|"
					strBuf = strBuf & objAct.department & "|"
					strBuf = strBuf & objAct.streetAddress & "|"
					strBuf = strBuf & strRoom & "|"
					strBuf = strBuf & objAct.l & "|"
					strBuf = strBuf & objAct.st & "|"
					strBuf = strBuf & objAct.postalCode & "|"
					strBuf = strBuf & strManager & "|"
					objUsr.Add objAct.samAccountName, strBuf
				Else
					If InStr(1, strClass, "group") > 0 Then
						objGrp.add objAct.samAccountName, objAct.ADsPath
					End If
				End If
			Next
	    	adoRec.MoveNext
		Wend
		
		'--> Connect to Outlook
		Set olkApp = CreateObject("Outlook.Application")
		Set olkSes = olkApp.GetNamespace("MAPI")
		olkSes.Logon olkApp.DefaultProfileName
		Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Folders(TARGET_FOLDER_NAME)
		If IsEmpty(olkFld) Then
			Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Folders.Add(TARGET_FOLDER_NAME)
		End If
		
		'--> Delete the items from the Outlook folder
		For lngCnt = olkFld.Items.Count To 1 Step -1
			olkFld.Items.Remove lngCnt
		Next
		
		'--> Read the contacts downloaded from AD and add them to Outlook
		arrTmp = objUsr.Items
		For Each varTmp In arrTmp
			arrItm = Split(varTmp, "|")
			If (arrItm(1) = "") Or (arrItm(2) = "") Or (arrItm(4) = "") Then
			Else
				Set olkCon = olkFld.Items.Add
				olkCon.nickname = arrItm(0)
				With olkCon
					.LastName = arrItm(1)
					.Firstname = arrItm(2)
					.JobTitle = arrItm(3)
			        .Email1Address = arrItm(4)
			        .BusinessTelephoneNumber = arrItm(5)
			        .MobileTelephoneNumber = arrItm(6)
			        .OfficeLocation = arrItm(7)
			        .CompanyName = arrItm(8)
			        .Department = arrItm(9)
			        .BusinessAddressStreet = arrItm(10)
			        .BusinessAddressCity = arrItm(12)
			        .BusinessAddressState = arrItm(13)
			        .BusinessAddressPostalCode = arrItm(14)
			        .ManagerName = arrItm(15)
			        .Categories = "AutoUpdate"
			        .Save
				End With
				Set olkCon = Nothing
			End If
		Next
		
		'--> Read the groups downloaded from AD and add them to Outlook
		arrTmp = objGrp.Items
		For Each varTmp In arrTmp
			CopyGroup varTmp
		Next
	
		'--> Disconnect from Outlook
		olkSes.Logoff
		Set olkFld = Nothing
		Set olkSes = Nothing
		Set olkApp = Nothing
	End If
	
'--> Clean up AD objects
	adoRec.Close
	Set adoRec = Nothing
	adoCon.Close
	Set adoCon = Nothing

'--> Clean up other objects
	Set objUsr = Nothing
	Set objGrp = Nothing
	Set objAct = Nothing
	Set objADRDSE = Nothing
	
'--> Notify the user that the script has finished then terminate processing
	MsgBox "Synchronization complete.", vbInformation+vbOKOnly, SCRIPT_NAME
	WScript.Quit

Sub CopyGroup(varPath)
	Const olDistributionListItem = 7
	Dim objGrp, olkGrp, olkRec, varMem, objAct
	Set objGrp = GetObject(varPath)
	Set olkGrp = olkFld.Items.Add(olDistributionListItem)
	olkGrp.Subject = objGrp.displayName
	'Set olkGrp = olkApp.CreateItem(olDistributionListItem)
	For Each varMem In objGrp.member
		Set objAct = GetObject("LDAP://" & varMem)
		If objAct.mail <> "" Then
			Set olkRec = olkSes.CreateRecipient(objAct.mail)
			olkRec.Resolve
			If olkRec.Resolved Then
				olkGrp.AddMember olkRec
			End If
		End If
	Next
	olkGrp.Save
	Set objGrp = Nothing
	Set olkGrp = Nothing
	Set olkRec = Nothing
	Set objAct = Nothing	
End Sub

Open in new window

Avatar of ITPro44

ASKER

The script runs and does everything else just fine, but contacts are still not being synced.
Are you certain the group contains contacts?  If it does, then does each contact entry have the first name, last name, and email address filled out?  If any of those are missing, then the code skips over the item.
Avatar of ITPro44

ASKER

Hey David, you were right!  This contact did not have an email address associated with it.  That said, is it possible to remove the check for the email address?  I should also ask if this is advisable as I'm not exactly sure your intent for making it this way.  Please advise.
Avatar of ITPro44

ASKER

Hi David - on a different topic, I have created seperate question that requires similar scripting abilities within outlook.  This script will actually complement what you have helped me create here.  I would be happy if you could help on this question.  thanks!

https://www.experts-exchange.com/questions/28942837/Script-a-way-to-Delete-Contacts-within-Oulook.html
It is possible to remove that filter, but I don't recommend it.  What's the point in having an entry in a email distribution list that doesn't have an email address?
Avatar of ITPro44

ASKER

Because this is use to sync contacts in addition to users, some of the contacts only have a phone number.  i.e. phone numbers for different office in this specific scenario.  

Is there a specific reason you don't recommend it?
No, there's no technical reason not to  It just seems odd to have entries without email addresses.  I've removed that restriction from this version.

'--> Create some constants
	'On the next line edit the email address of the list to sync from
	Const DISTRIBUTION_GROUP_ADDRESS = "somelist@company.com"
	'On the next line edit the name of the Outlook folder to sync to
	Const TARGET_FOLDER_NAME = "Company Contacts"
	Const SCRIPT_NAME = "List Sychronization (v1.0)"
	Const olFolderContacts = 10

'--> Create some variables
	Dim objUsr, objGrp, objAct, objManager, objADRDSE 
	Dim olkApp, olkSes, olkFld, olkCon
	Dim adoCon, adoRec
	Dim arrRooms, strRoom, strManager, strClass, strBuf, arrTmp, varTmp, arrItm, lngCnt, strSource, strDNC
	
'--> Initialize some variables
	Set objUsr = CreateObject("Scripting.Dictionary")
	Set objGrp = CreateObject("Scripting.Dictionary")

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

'--> get the AD root
	Set objADRDSE = GetObject("LDAP://RootDSE")
	strDNC = objADRDSE.Get("defaultnamingcontext")
	strSource = "LDAP://" & strDNC
	
'--> Connect to and read AD
	Set adoCon = CreateObject("ADODB.Connection")
	With adoCon
		.CursorLocation = 3
		.Provider = "ADsDSOObject"
		.Open "ADSI"
	End With
	Set adoRec = adoCon.Execute("SELECT adsPath,member FROM '" &  strSource & "' WHERE objectClass='group' AND mail='" & DISTRIBUTION_GROUP_ADDRESS & "'")
	If Not IsEmpty(adoRec) Then
		'--> Read AD
		While Not adoRec.EOF
		    arrMembers = adoRec.Fields("Member")
		    For Each varMember In arrMembers
				Set objAct = GetObject("LDAP://" & varMember)
				strClass = Join(objAct.objectClass, ",")
				If (InStr(1, strClass, "user") > 0) Or (InStr(1, strClass, "contact") > 0) Then
					If Not IsNull(objAct.roomNumber) Then
						arrRooms = objAct.roomNumber
						strRoom = arrRooms(0)
					Else
						strRoom = ""
					End If
					If Not IsNull(objAct.manager) Then
						Set objManager = GetObject("LDAP://" &  objAct.manager)
						strManager = objManager.DisplayName
					Else
						strManager = ""
					End If
					Set objManager = Nothing
					strBuf = objAct.samAccountName & "|"
					strBuf = strBuf & objAct.sn & "|"
					strBuf = strBuf & objAct.givenName & "|"
					strBuf = strBuf & objAct.title & "|"
					strBuf = strBuf & objAct.mail & "|"
					strBuf = strBuf & objAct.telephoneNumber & "|"
					strBuf = strBuf & objAct.mobile & "|"
					strBuf = strBuf & objAct.physicalDeliveryOfficeName & "|"
					strBuf = strBuf & objAct.company & "|"
					strBuf = strBuf & objAct.department & "|"
					strBuf = strBuf & objAct.streetAddress & "|"
					strBuf = strBuf & strRoom & "|"
					strBuf = strBuf & objAct.l & "|"
					strBuf = strBuf & objAct.st & "|"
					strBuf = strBuf & objAct.postalCode & "|"
					strBuf = strBuf & strManager & "|"
					objUsr.Add objAct.samAccountName, strBuf
				Else
					If InStr(1, strClass, "group") > 0 Then
						objGrp.add objAct.samAccountName, objAct.ADsPath
					End If
				End If
			Next
	    	adoRec.MoveNext
		Wend
		
		'--> Connect to Outlook
		Set olkApp = CreateObject("Outlook.Application")
		Set olkSes = olkApp.GetNamespace("MAPI")
		olkSes.Logon olkApp.DefaultProfileName
		Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Folders(TARGET_FOLDER_NAME)
		If IsEmpty(olkFld) Then
			Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Folders.Add(TARGET_FOLDER_NAME)
		End If
		
		'--> Delete the items from the Outlook folder
		For lngCnt = olkFld.Items.Count To 1 Step -1
			olkFld.Items.Remove lngCnt
		Next
		
		'--> Read the contacts downloaded from AD and add them to Outlook
		arrTmp = objUsr.Items
		For Each varTmp In arrTmp
			arrItm = Split(varTmp, "|")
			If (arrItm(1) = "") Or (arrItm(2) = "") Then
			Else
				Set olkCon = olkFld.Items.Add
				olkCon.nickname = arrItm(0)
				With olkCon
					.LastName = arrItm(1)
					.Firstname = arrItm(2)
					.JobTitle = arrItm(3)
			        .Email1Address = arrItm(4)
			        .BusinessTelephoneNumber = arrItm(5)
			        .MobileTelephoneNumber = arrItm(6)
			        .OfficeLocation = arrItm(7)
			        .CompanyName = arrItm(8)
			        .Department = arrItm(9)
			        .BusinessAddressStreet = arrItm(10)
			        .BusinessAddressCity = arrItm(12)
			        .BusinessAddressState = arrItm(13)
			        .BusinessAddressPostalCode = arrItm(14)
			        .ManagerName = arrItm(15)
			        .Categories = "AutoUpdate"
			        .Save
				End With
				Set olkCon = Nothing
			End If
		Next
		
		'--> Read the groups downloaded from AD and add them to Outlook
		arrTmp = objGrp.Items
		For Each varTmp In arrTmp
			CopyGroup varTmp
		Next
	
		'--> Disconnect from Outlook
		olkSes.Logoff
		Set olkFld = Nothing
		Set olkSes = Nothing
		Set olkApp = Nothing
	End If
	
'--> Clean up AD objects
	adoRec.Close
	Set adoRec = Nothing
	adoCon.Close
	Set adoCon = Nothing

'--> Clean up other objects
	Set objUsr = Nothing
	Set objGrp = Nothing
	Set objAct = Nothing
	Set objADRDSE = Nothing
	
'--> Notify the user that the script has finished then terminate processing
	MsgBox "Synchronization complete.", vbInformation+vbOKOnly, SCRIPT_NAME
	WScript.Quit

Sub CopyGroup(varPath)
	Const olDistributionListItem = 7
	Dim objGrp, olkGrp, olkRec, varMem, objAct
	Set objGrp = GetObject(varPath)
	Set olkGrp = olkFld.Items.Add(olDistributionListItem)
	olkGrp.Subject = objGrp.displayName
	'Set olkGrp = olkApp.CreateItem(olDistributionListItem)
	For Each varMem In objGrp.member
		Set objAct = GetObject("LDAP://" & varMem)
		If objAct.mail <> "" Then
			Set olkRec = olkSes.CreateRecipient(objAct.mail)
			olkRec.Resolve
			If olkRec.Resolved Then
				olkGrp.AddMember olkRec
			End If
		End If
	Next
	olkGrp.Save
	Set objGrp = Nothing
	Set olkGrp = Nothing
	Set olkRec = Nothing
	Set objAct = Nothing	
End Sub

Open in new window

Avatar of ITPro44

ASKER

Thanks David, that's great!
I just realized that there are some additional fields that we need to synchronize.  Can you add the following fields?:
1. Fax Number
2. IP Phone
3. Home Phone
4. Web Page
Ok, I've added those additional fields.  Outlook contacts do not have a field specifically for the IP phone number, so I have the solution inserting that into the second business telephone number.  If you want it in some other field, then let me know which one and I'll move it there.

'--> Create some constants
	'On the next line edit the email address of the list to sync from
	Const DISTRIBUTION_GROUP_ADDRESS = "somelist@company.com"
	'On the next line edit the name of the Outlook folder to sync to
	Const TARGET_FOLDER_NAME = "Company Contacts"
	Const SCRIPT_NAME = "List Sychronization (v1.0)"
	Const olFolderContacts = 10

'--> Create some variables
	Dim objUsr, objGrp, objAct, objManager, objADRDSE 
	Dim olkApp, olkSes, olkFld, olkCon
	Dim adoCon, adoRec
	Dim arrRooms, strRoom, strManager, strClass, strBuf, arrTmp, varTmp, arrItm, lngCnt, strSource, strDNC
	
'--> Initialize some variables
	Set objUsr = CreateObject("Scripting.Dictionary")
	Set objGrp = CreateObject("Scripting.Dictionary")

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

'--> get the AD root
	Set objADRDSE = GetObject("LDAP://RootDSE")
	strDNC = objADRDSE.Get("defaultnamingcontext")
	strSource = "LDAP://" & strDNC
	
'--> Connect to and read AD
	Set adoCon = CreateObject("ADODB.Connection")
	With adoCon
		.CursorLocation = 3
		.Provider = "ADsDSOObject"
		.Open "ADSI"
	End With
	Set adoRec = adoCon.Execute("SELECT adsPath,member FROM '" &  strSource & "' WHERE objectClass='group' AND mail='" & DISTRIBUTION_GROUP_ADDRESS & "'")
	If Not IsEmpty(adoRec) Then
		'--> Read AD
		While Not adoRec.EOF
		    arrMembers = adoRec.Fields("Member")
		    For Each varMember In arrMembers
				Set objAct = GetObject("LDAP://" & varMember)
				strClass = Join(objAct.objectClass, ",")
				If (InStr(1, strClass, "user") > 0) Or (InStr(1, strClass, "contact") > 0) Then
					If Not IsNull(objAct.roomNumber) Then
						arrRooms = objAct.roomNumber
						strRoom = arrRooms(0)
					Else
						strRoom = ""
					End If
					If Not IsNull(objAct.manager) Then
						Set objManager = GetObject("LDAP://" &  objAct.manager)
						strManager = objManager.DisplayName
					Else
						strManager = ""
					End If
					Set objManager = Nothing
					strBuf = objAct.samAccountName & "|"
					strBuf = strBuf & objAct.sn & "|"
					strBuf = strBuf & objAct.givenName & "|"
					strBuf = strBuf & objAct.title & "|"
					strBuf = strBuf & objAct.mail & "|"
					strBuf = strBuf & objAct.telephoneNumber & "|"
					strBuf = strBuf & objAct.mobile & "|"
					strBuf = strBuf & objAct.physicalDeliveryOfficeName & "|"
					strBuf = strBuf & objAct.company & "|"
					strBuf = strBuf & objAct.department & "|"
					strBuf = strBuf & objAct.streetAddress & "|"
					strBuf = strBuf & strRoom & "|"
					strBuf = strBuf & objAct.l & "|"
					strBuf = strBuf & objAct.st & "|"
					strBuf = strBuf & objAct.postalCode & "|"
					strBuf = strBuf & strManager & "|"
					strBuf = strBuf & objAct.facsimileTelephoneNumber & "|"
					strBuf = strBuf & objAct.homePhone & "|"
					strBuf = strBuf & objAct.ipPhone & "|"
					strBuf = strBuf & objAct.wWWHomePage & "|"
					objUsr.Add objAct.samAccountName, strBuf
				Else
					If InStr(1, strClass, "group") > 0 Then
						objGrp.add objAct.samAccountName, objAct.ADsPath
					End If
				End If
			Next
	    	adoRec.MoveNext
		Wend
		
		'--> Connect to Outlook
		Set olkApp = CreateObject("Outlook.Application")
		Set olkSes = olkApp.GetNamespace("MAPI")
		olkSes.Logon olkApp.DefaultProfileName
		Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Folders(TARGET_FOLDER_NAME)
		If IsEmpty(olkFld) Then
			Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Folders.Add(TARGET_FOLDER_NAME)
		End If
		
		'--> Delete the items from the Outlook folder
		For lngCnt = olkFld.Items.Count To 1 Step -1
			olkFld.Items.Remove lngCnt
		Next
		
		'--> Read the contacts downloaded from AD and add them to Outlook
		arrTmp = objUsr.Items
		For Each varTmp In arrTmp
			arrItm = Split(varTmp, "|")
			If (arrItm(1) = "") Or (arrItm(2) = "") Then
			Else
				Set olkCon = olkFld.Items.Add
				olkCon.nickname = arrItm(0)
				With olkCon
					.LastName = arrItm(1)
					.Firstname = arrItm(2)
					.JobTitle = arrItm(3)
			        .Email1Address = arrItm(4)
			        .BusinessTelephoneNumber = arrItm(5)
			        .MobileTelephoneNumber = arrItm(6)
			        .OfficeLocation = arrItm(7)
			        .CompanyName = arrItm(8)
			        .Department = arrItm(9)
			        .BusinessAddressStreet = arrItm(10)
			        .BusinessAddressCity = arrItm(12)
			        .BusinessAddressState = arrItm(13)
			        .BusinessAddressPostalCode = arrItm(14)
			        .ManagerName = arrItm(15)
			        .BusinesFaxNumber = arrItm(16)
			        .HomeTelephoneNumber = arrItm(17)
			        .Business2TelephoneNumber = arrItm(18)
			        .WebPage = arrItm(19)
			        .Categories = "AutoUpdate"
			        .Save
				End With
				Set olkCon = Nothing
			End If
		Next
		
		'--> Read the groups downloaded from AD and add them to Outlook
		arrTmp = objGrp.Items
		For Each varTmp In arrTmp
			CopyGroup varTmp
		Next
	
		'--> Disconnect from Outlook
		olkSes.Logoff
		Set olkFld = Nothing
		Set olkSes = Nothing
		Set olkApp = Nothing
	End If
	
'--> Clean up AD objects
	adoRec.Close
	Set adoRec = Nothing
	adoCon.Close
	Set adoCon = Nothing

'--> Clean up other objects
	Set objUsr = Nothing
	Set objGrp = Nothing
	Set objAct = Nothing
	Set objADRDSE = Nothing
	
'--> Notify the user that the script has finished then terminate processing
	MsgBox "Synchronization complete.", vbInformation+vbOKOnly, SCRIPT_NAME
	WScript.Quit

Sub CopyGroup(varPath)
	Const olDistributionListItem = 7
	Dim objGrp, olkGrp, olkRec, varMem, objAct
	Set objGrp = GetObject(varPath)
	Set olkGrp = olkFld.Items.Add(olDistributionListItem)
	olkGrp.Subject = objGrp.displayName
	'Set olkGrp = olkApp.CreateItem(olDistributionListItem)
	For Each varMem In objGrp.member
		Set objAct = GetObject("LDAP://" & varMem)
		If objAct.mail <> "" Then
			Set olkRec = olkSes.CreateRecipient(objAct.mail)
			olkRec.Resolve
			If olkRec.Resolved Then
				olkGrp.AddMember olkRec
			End If
		End If
	Next
	olkGrp.Save
	Set objGrp = Nothing
	Set olkGrp = Nothing
	Set olkRec = Nothing
	Set objAct = Nothing	
End Sub

Open in new window

Avatar of ITPro44

ASKER

thank you.  So I'm running into several problems.  

1. Only one contact will Sync.  Multiple contacts within a set distribution group will not sync.
2. Fax numbers are not syncing.
3. I have removed the work phone number from all contacts with AD last week.  This work number is still being synchronized.  I have no idea where the script is pulling this info from.  Any ideas what's going on here?
Avatar of ITPro44

ASKER

problem 1 and 3 exists in the previous code as well.
Avatar of ITPro44

ASKER

ok, scratch problem 3, that is not an issue.
Sorry, but I don't understand what #1 means.  

This version fixes a typo which was causing #2.  

'--> Create some constants
	'On the next line edit the email address of the list to sync from
	Const DISTRIBUTION_GROUP_ADDRESS = "somelist@company.com"
	'On the next line edit the name of the Outlook folder to sync to
	Const TARGET_FOLDER_NAME = "Company Contacts"
	Const SCRIPT_NAME = "List Sychronization (v1.0)"
	Const olFolderContacts = 10

'--> Create some variables
	Dim objUsr, objGrp, objAct, objManager, objADRDSE 
	Dim olkApp, olkSes, olkFld, olkCon
	Dim adoCon, adoRec
	Dim arrRooms, strRoom, strManager, strClass, strBuf, arrTmp, varTmp, arrItm, lngCnt, strSource, strDNC
	
'--> Initialize some variables
	Set objUsr = CreateObject("Scripting.Dictionary")
	Set objGrp = CreateObject("Scripting.Dictionary")

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

'--> get the AD root
	Set objADRDSE = GetObject("LDAP://RootDSE")
	strDNC = objADRDSE.Get("defaultnamingcontext")
	strSource = "LDAP://" & strDNC
	
'--> Connect to and read AD
	Set adoCon = CreateObject("ADODB.Connection")
	With adoCon
		.CursorLocation = 3
		.Provider = "ADsDSOObject"
		.Open "ADSI"
	End With
	Set adoRec = adoCon.Execute("SELECT adsPath,member FROM '" &  strSource & "' WHERE objectClass='group' AND mail='" & DISTRIBUTION_GROUP_ADDRESS & "'")
	If Not IsEmpty(adoRec) Then
		'--> Read AD
		While Not adoRec.EOF
		    arrMembers = adoRec.Fields("Member")
		    For Each varMember In arrMembers
				Set objAct = GetObject("LDAP://" & varMember)
				strClass = Join(objAct.objectClass, ",")
				If (InStr(1, strClass, "user") > 0) Or (InStr(1, strClass, "contact") > 0) Then
					If Not IsNull(objAct.roomNumber) Then
						arrRooms = objAct.roomNumber
						strRoom = arrRooms(0)
					Else
						strRoom = ""
					End If
					If Not IsNull(objAct.manager) Then
						Set objManager = GetObject("LDAP://" &  objAct.manager)
						strManager = objManager.DisplayName
					Else
						strManager = ""
					End If
					Set objManager = Nothing
					strBuf = objAct.samAccountName & "|"
					strBuf = strBuf & objAct.sn & "|"
					strBuf = strBuf & objAct.givenName & "|"
					strBuf = strBuf & objAct.title & "|"
					strBuf = strBuf & objAct.mail & "|"
					strBuf = strBuf & objAct.telephoneNumber & "|"
					strBuf = strBuf & objAct.mobile & "|"
					strBuf = strBuf & objAct.physicalDeliveryOfficeName & "|"
					strBuf = strBuf & objAct.company & "|"
					strBuf = strBuf & objAct.department & "|"
					strBuf = strBuf & objAct.streetAddress & "|"
					strBuf = strBuf & strRoom & "|"
					strBuf = strBuf & objAct.l & "|"
					strBuf = strBuf & objAct.st & "|"
					strBuf = strBuf & objAct.postalCode & "|"
					strBuf = strBuf & strManager & "|"
					strBuf = strBuf & objAct.facsimileTelephoneNumber & "|"
					strBuf = strBuf & objAct.homePhone & "|"
					strBuf = strBuf & objAct.ipPhone & "|"
					strBuf = strBuf & objAct.wWWHomePage & "|"
					objUsr.Add objAct.samAccountName, strBuf
				Else
					If InStr(1, strClass, "group") > 0 Then
						objGrp.add objAct.samAccountName, objAct.ADsPath
					End If
				End If
			Next
	    	adoRec.MoveNext
		Wend
		
		'--> Connect to Outlook
		Set olkApp = CreateObject("Outlook.Application")
		Set olkSes = olkApp.GetNamespace("MAPI")
		olkSes.Logon olkApp.DefaultProfileName
		Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Folders(TARGET_FOLDER_NAME)
		If IsEmpty(olkFld) Then
			Set olkFld = olkSes.GetDefaultFolder(olFolderContacts).Folders.Add(TARGET_FOLDER_NAME)
		End If
		
		'--> Delete the items from the Outlook folder
		For lngCnt = olkFld.Items.Count To 1 Step -1
			olkFld.Items.Remove lngCnt
		Next
		
		'--> Read the contacts downloaded from AD and add them to Outlook
		arrTmp = objUsr.Items
		For Each varTmp In arrTmp
			arrItm = Split(varTmp, "|")
			If (arrItm(1) = "") Or (arrItm(2) = "") Then
			Else
				Set olkCon = olkFld.Items.Add
				olkCon.nickname = arrItm(0)
				With olkCon
					.LastName = arrItm(1)
					.Firstname = arrItm(2)
					.JobTitle = arrItm(3)
			        .Email1Address = arrItm(4)
			        .BusinessTelephoneNumber = arrItm(5)
			        .MobileTelephoneNumber = arrItm(6)
			        .OfficeLocation = arrItm(7)
			        .CompanyName = arrItm(8)
			        .Department = arrItm(9)
			        .BusinessAddressStreet = arrItm(10)
			        .BusinessAddressCity = arrItm(12)
			        .BusinessAddressState = arrItm(13)
			        .BusinessAddressPostalCode = arrItm(14)
			        .ManagerName = arrItm(15)
			        .BusinessFaxNumber = arrItm(16)
			        .HomeTelephoneNumber = arrItm(17)
			        .Business2TelephoneNumber = arrItm(18)
			        .WebPage = arrItm(19)
			        .Categories = "AutoUpdate"
			        .Save
				End With
				Set olkCon = Nothing
			End If
		Next
		
		'--> Read the groups downloaded from AD and add them to Outlook
		arrTmp = objGrp.Items
		For Each varTmp In arrTmp
			CopyGroup varTmp
		Next
	
		'--> Disconnect from Outlook
		olkSes.Logoff
		Set olkFld = Nothing
		Set olkSes = Nothing
		Set olkApp = Nothing
	End If
	
'--> Clean up AD objects
	adoRec.Close
	Set adoRec = Nothing
	adoCon.Close
	Set adoCon = Nothing

'--> Clean up other objects
	Set objUsr = Nothing
	Set objGrp = Nothing
	Set objAct = Nothing
	Set objADRDSE = Nothing
	
'--> Notify the user that the script has finished then terminate processing
	MsgBox "Synchronization complete.", vbInformation+vbOKOnly, SCRIPT_NAME
	WScript.Quit

Sub CopyGroup(varPath)
	Const olDistributionListItem = 7
	Dim objGrp, olkGrp, olkRec, varMem, objAct
	Set objGrp = GetObject(varPath)
	Set olkGrp = olkFld.Items.Add(olDistributionListItem)
	olkGrp.Subject = objGrp.displayName
	'Set olkGrp = olkApp.CreateItem(olDistributionListItem)
	For Each varMem In objGrp.member
		Set objAct = GetObject("LDAP://" & varMem)
		If objAct.mail <> "" Then
			Set olkRec = olkSes.CreateRecipient(objAct.mail)
			olkRec.Resolve
			If olkRec.Resolved Then
				olkGrp.AddMember olkRec
			End If
		End If
	Next
	olkGrp.Save
	Set objGrp = Nothing
	Set olkGrp = Nothing
	Set olkRec = Nothing
	Set objAct = Nothing	
End Sub

Open in new window

Avatar of ITPro44

ASKER

I have a distribution group with eight contacts in it. (Not users but contacts).  Only one contact gets synced, not all eight. If i remove the one that is getting synced from the group, that one will get removed and another will be synced.  Its like once one contact gets added it stops looking for more.
ASKER CERTIFIED SOLUTION
Avatar of David Lee
David Lee
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of ITPro44

ASKER

that worked!  thank you!
Avatar of ITPro44

ASKER

one last question.  Many of our offices can dial out from different phone numbers.  In order for cell phones to recognize and pop the correct contact, all numbers have be to programmed into the contact, which could be up to 10 numbers. What do you think the best way to do this is.  One option is putting numbers as Other, but maybe there is a better way.

User generated image
An Outlook contact has 19 fields for phone numbers.  An account/contact in AD appears to have about 15 phone number fields though only 5 are generally visible.  I can have the script map any phone number field in AD to any phone number field in an Outlook contact.  It's really just a matter of determining which phone number fields to use on both ends and then mapping them accordingly.
Avatar of ITPro44

ASKER

I'm still planning to respond to this, but wanted to get the other question we have going finished first.
Avatar of ITPro44

ASKER

I would like to award points and an answer.
Avatar of ITPro44

ASKER

How do I mark the question as answered?
Avatar of ITPro44

ASKER

David, thanks for much for this script!  great work!