ContactImport

ContactImport.vbs

Option Explicit

' ContactImport.vbs
'
' Contact Import / Maintenance Script

'
' Subroutines
'

Sub WriteLog(strMessage, booLogOnly)
	Dim strScriptHost
	Dim booShowCommandLine

	strScriptHost = WScript.FullName
	strScriptHost = Right(strScriptHost, Len(strScriptHost) - InStrRev(strScriptHost, "\"))

	booShowCommandLine = True
	If (UCase(strScriptHost) = "WSCRIPT.EXE") Then
		booShowCommandLine = False
	End If
	If booLogOnly = True Then
		booShowCommandLine = False
	End If

	objLogFile.WriteLine "[" & Now() & "] " & strMessage
	If booShowCommandLine = True Then
		wscript.echo "[" & Now() & "] " & strMessage
	End If
End Sub

Sub UsageText
	Dim strMessage

	strMessage = "Usage:" & VbCrLf & VbCrLf
	strMessage = strMessage & "cscript " & WScript.ScriptName & " -f <File Name> " & VbCrLf & VbTab
	strMessage = strMessage & "-o ""<Organisational Unit Path>"" [-r] [-s] [-a <Attributes>] " & VbCrLf & VbTab
	strMessage = strMessage & "[-d <Delimiter>] [-n ""<Name Format>""] [-t]" & VbCrLf
	strMessage = strMessage & VbCrLf
	strMessage = strMessage & "Options:" & VbCrLf
	strMessage = strMessage & VbTab & "-f <File Name> - Input File Name (Required)" & VbCrLf
	strMessage = strMessage & VbTab & "-o <Organisational Unit Path> - Target OU for Contact Objects (Required)" & VbCrLf
	strMessage = strMessage & VbTab & "-r - Read the Header Line as AD Fields" & VbCrLf
	strMessage = strMessage & VbTab & "-s - Skip the Header Line" & VbCrLf
	strMessage = strMessage & VbTab & "-a <Attributes> - AD Attibutes to write Fields to (Required " & VbCrLf
	strMessage = strMessage & VbTab & "if not using Header)" & VbCrLf
	strMessage = strMessage & VbTab & "-d <Delimiter> - File Delimiter. Uses comma if not specified." & VbCrlf
	strMessage = strMessage & VbTab & "-n <Name Format> - DisplayName and CN Format by AD Attributes." & VbCrLf
	strMessage = strMessage & VbTab & "Uses TargetAddress if not specified." & VbCrLf
	strMessage = strMessage & VbTab & "-t - Test Only" & VbCrLf
	WScript.Echo strMessage
	WScript.Quit
End Sub

Sub SortArgv
	Dim objArgv, objOU
	Dim strArgv
	Dim i, intFileName, intOrgUnit, intFields, intFileDelimiter, intDisplayNameFormat
	Dim booFileName, booOrgUnit, booFields, booFileDelimiter, booDisplayNameFormat

	Set objArgv = WScript.Arguments

	If objArgv.Count < 1 Then
		UsageText()
	End If

	booFileName = False : booOrgUnit = False : booReadHeader = False : booSkipHeader= False
	booFields = False : booFileDelimiter = False : booDisplayNameFormat = False
	booTestOnly = False

	i = 0

	For Each strArgv in objArgv
		i = i + 1
		strArgv = LCase(strArgv)
		If strArgv = "-f" Then ' Required
			booFileName = True
			intFileName = i
		ElseIf strArgv = "-o" Then ' Required
			booOrgUnit = True
			intOrgUnit = i
		ElseIf strArgv = "-r" Then ' Cannot be set as well as -s
			booReadHeader = True
		ElseIf strArgv = "-s" Then ' Cannot be set as well as -r. Must have -a
			booSkipHeader = True
		ElseIf strArgv = "-a" Then ' Required if booReadHeader = False
			booFields = True
			intFields = i
		ElseIf strArgv = "-d" Then ' Optional - Default ","
			booFileDelimiter = True
			intFileDelimiter = i
		ElseIf strArgv = "-n" Then ' Optional - Default targetAddress
			booDisplayNameFormat = True
			intDisplayNameFormat = i
		ElseIf strArgv = "-t" Then ' Optional - Test Mode
			booTestOnly = True
		End If
	Next
	
	' Check the requirements for the Arguments
	
	If booFileName = False Or booOrgUnit = False Then
		UsageText
	End If
	
	If booReadHeader = True And booSkipHeader = True Then
		UsageText
	End If
	
	If (booSkipHeader = True Or booReadHeader = False) And booFields = False Then
		UsageText
	End If
	
	' Read the Arguments into the Variables
	
	If booFileName = True Then
		If objArgv.Count < (intFileName + 1) Then
			UsageText
		Else
			strFileName = objArgv(intFileName)
		End If
	End If
	
	If booOrgUnit = True Then
		If objArgv.Count < (intOrgUnit +  1) Then
			UsageText
		Else
			strOrgUnit = objArgv(intOrgUnit)
		End If
		' Check Org Unit Path is Valid
		On Error Resume Next : Err.Clear
		Set objOU = GetObject("LDAP://" & strOrgUnit)
		Set objOU = Nothing
		If Err.Number <> 0 Then
			WScript.Echo "Error Connecting to OU: " & strOrgUnit
			WScript.Echo "Message: " & Err.Description & VbCrLf
			UsageText
		End If
		On Error Goto 0
	End If

	If booFields = True Then
		If objArgv.Count < (intFields + 1) Then
			UsageText
		Else
			strFields = objArgv(intFields)
		End If
	End If

	If booFileDelimiter = True Then
		If objArgv.Count < (intFileDelimiter + 1) Then
			UsageText
		Else
			strFileDelimiter = objArgv(intFileDelimiter)
		End If
	Else
		strFileDelimiter = ","
	End If

	If booDisplayNameFormat = True Then
		If objArgv.Count < (intDisplayNameFormat + 1) Then
			UsageText
		Else
			strDisplayNameFormat = objArgv(intDisplayNameFormat)
		End If
	Else
		strDisplayNameFormat = "targetAddress"
	End If
	
	Set objArgv = Nothing
End Sub

Sub ReadSource(strFileName)
	Dim objFile, objStream, objFileMap
	Dim strTemp, strLine, strField, strDisplayName, strTargetAddress, strLeft, strMid, strRight
	Dim arrFields, arrFieldData, arrUserData(), arrLine
	Dim i, j, k

	' Subroutine Start

	Set objFile = objFileSystem.GetFile(strFileName)
	Set objStream = objFile.OpenAsTextStream(1, 0)

	WriteLog "Reading Data File (" & objFile.Name & ")", False

	' These options are, in part, mutually exclusive. Command Line checks will resolve any conflicts.

	If booReadHeader = True Then
		arrFields = Split(objStream.ReadLine, strFileDelimiter)
	Else
		arrFields = Split(strFields, ",")
	End If
	
	' Quick Check to make sure TargetAddress is in there somewhere.
	
	strTemp = Join(arrFields, "")
	If InStr(1, strTemp, "targetAddress", VbTextCompare) = 0 Then
		WriteLog "Error in Data: No Target Address Defined", True
		UsageText()
	End If

	If booSkipHeader = True Then
		objStream.SkipLine
	End If
	
	' This is the Map for the files contents. Like fields must be contiguous and will be concatenated.
	
	Set objFileMap = CreateObject("Scripting.Dictionary")
	For i = 0 To UBound(arrFields)
		strField = LCase(arrFields(i))
		If Not objFileMap.Exists(strField) Then
			objFileMap.Add strField, Array(1, i)
		ElseIf objFileMap.Exists(strField) Then
			arrFieldData = objFileMap(strField)
			arrFieldData(0) = arrFieldData(0) + 1
			objFileMap(strField) = arrFieldData
		End If
	Next
	
	' Use Global strDisplayNameFormat. Match every value that appears in objFileMap.
	' Gets a bit hairy if l is included in input along with initials in format (for example)
	
	For Each strField in objFileMap
		If InStr(1, strDisplayNameFormat, strField, VbTextCompare) Then
			strDisplayNameFormat = Replace(strDisplayNameFormat, strField, _
				objFileMap(strField)(1), 1, -1, VbTextCompare)
		End if
	Next
	
	' Read the File based on the Map and load into objData.
		
	Do While Not objStream.AtEndOfStream
		strLine = objStream.ReadLine
		
		' Nasty bit of code to get rid of quoted fields with comma's in - breaks CSV
		
		Do Until InStr(strLine, """") = 0
			If InStr(strLine, """") Then
				strLeft = Left(strLine, InStr(strLine, """") - 1)
				strLine = Right(strLine, Len(strLine) - InStr(strLine, """"))
				strMid =  Replace(Left(strLine, InStr(strLine, """") - 1), ",", "")
				strRight = Right(strLine, Len(strLine) - InStr(strLine, """"))
				strLine = strLeft & strMid & strRight
			End If
		Loop
		
		arrLine = Split(strLine, strFileDelimiter)
		strTargetAddress = LCase(arrLine(objFileMap("targetaddress")(1)))
	
		strDisplayName = strDisplayNameFormat
		For i = 0 to UBound(arrLine)
			strDisplayName = Replace(strDisplayName, i, arrLine(i))
		Next
	
		' Code to cope with multiple fields of the same name. Concatenates with a comma and a space.
		' Prefixes every other field with the attribute it's to be loaded into.

		ReDim arrUserData(UBound(arrLine) - 1)
		j = 0
		For Each strField in objFileMap
			If LCase(strField) <> "targetaddress" Then
				If objFileMap(strField)(0) > 1 And arrUserData(j) = "" Then
					strTemp = ""
					For k = 1 to objFileMap(strField)(0)
						If arrLine(j + k) <> "" Then
							strTemp = strTemp & Trim(arrLine(j + k)) & ", "
						End If
					Next
					If Len(strTemp) > 2 Then
						strTemp = Left(strTemp, Len(strTemp) - 2)
					End If
					arrUserData(j) = strField & "=" & strTemp
				ElseIf arrUserData(j) = "" Then
					arrUserData(j) = strField & "=" & Trim(arrLine(objFileMap(strField)(1)))
				End If
				j = j + 1
			End If
		Next

		objData.Add strTargetAddress, Array(strDisplayName, arrUserData)
		
		' Cleanup the Array for the next data entry
		Erase arrUserData
	Loop

	WriteLog "Completed Reading Data File (" & objFile.Name & ")", False

	Set objStream = Nothing
	Set objFile = Nothing
End Sub

Sub CheckADData
	Const ADS_SCOPE_SUBTREE = 2

	Dim objConnection, objCommand, objRootDSE, objRecordSet
	Dim strAddress
	Dim arrAddresses

	WriteLog "Checking for Duplicate Addresses", False

	Set objConnection = CreateObject("ADODB.Connection")
	objConnection.Provider = "ADsDSOObject"
	objConnection.Open "Active Directory Provider"

	Set objCommand = CreateObject("ADODB.Command")
	objCommand.ActiveConnection = objConnection

	Set objRootDSE = GetObject("LDAP://RootDSE")
	objCommand.CommandText = "SELECT displayName, aDSPath, proxyAddresses " &_
		"FROM 'GC://" & objRootDSE.Get("rootDomainNamingContext") & "'"
	Set objRootDSE = nothing

	objCommand.Properties("Page Size") = 1000
	objCommand.Properties("Timeout") = 600
	objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
	objCommand.Properties("Cache Results") = False

	Set objRecordSet = objCommand.Execute

	While Not objRecordSet.EOF
		If Not IsNull(objRecordSet.Fields("proxyAddresses")) Then
			arrAddresses = objRecordSet.Fields("proxyAddresses")
			
			For Each strAddress in arrAddresses
				If InStr(1, strAddress, "smtp:", VbTextCompare) Then
					strAddress = LCase(Replace(strAddress, "smtp:", "", 1, -1, 1))
					If objData.Exists(strAddress) Then
						WriteLog "Duplicate Email Address Found:", True
						WriteLog "Removed: " & strAddress & ": " & objData(strAddress)(0), True
						WriteLog "Existing Address On: " & objRecordSet.Fields("aDSPath"), True
						objData.Remove strAddress
						intDiscarded = intDiscarded + 1
					End If
				End If
			Next
		End If

		objRecordSet.MoveNext
	Wend
	objConnection.Close

	Set objRecordSet = Nothing
	Set objCommand = Nothing
	Set objConnection = Nothing
End Sub

Sub SyncContacts
	Dim objContact
	Dim strAddress, strCN, strDN
	Dim booCreate

	WriteLog "Synchronising Contacts", False

	intCreated = 0
	intUpdated = 0

	For Each strAddress in objData
		strCN = "CN=" & Replace(objData(strAddress)(0), ",", "\,")
		strDN = strCN & "," & strOrgUnit

		If Not objContactList.Exists(strDN) Then
			objContactList.Add strDN, ""
		End If
	
		On Error Resume Next : Err.Clear
		Set objContact = GetObject("LDAP://" & strDN)
		Set objContact = Nothing
		If Err.Number <> 0 Then
			booCreate = True
		Else
			booCreate = False
		End If
		On Error Goto 0

		If booCreate = True Then
			intCreated = intCreated + 1
			AddContact strAddress, strCN
		Else
			intUpdated = intUpdated + 1
			UpdateContact strAddress, strDN
		End If
	Next
	
	' DeleteOldContacts

	WriteLog "Completed Synchronising Contacts", False
End Sub

Sub AddContact(strAddress, strCN)
	Dim objOU, objContact
	Dim strDisplayName, strData, strAttribute, strValue
	Dim arrTemp

	strDisplayName = objData(strAddress)(0)
	WriteLog "Adding Contact: " & strDisplayName, True

	Set objOU = GetObject("LDAP://" & strOrgUnit)

	If booTestOnly = False Then
		On Error Resume Next : Err.Clear
		Set objContact = objOU.Create("contact", strCN)
		objContact.Put "displayName", strDisplayName
		objContact.SetInfo
	
		If Err.Number = 0 Then
			Err.Clear
			objContact.MailEnable strAddress
			If Err.Number <> 0 Then
				WriteLog "Error Mail Enabling " & strDisplayName & ": " & Err.Description, True
			End If
		Else
			WriteLog "Error Configuring " & strDisplayName & ": " & Err.Description, True
		End If
		
		For Each strData in objData(strAddress)(1)
			arrTemp = Split(strData, "=")
			strAttribute = arrTemp(0)
			strValue = arrTemp(1)
			
			CheckUpdate objContact, strAttribute, strValue
		Next
		Set objContact = Nothing
	End If
	Set objOU = Nothing
	On Error Goto 0
End Sub

Sub UpdateContact(strAddress, strDN)
	Dim objContact
	Dim strSMTPAddress, strDisplayName, strData, strAttribute, strValue
	Dim arrAddresses, arrTemp

	Set objContact = GetObject("LDAP://" & strDN)

	CheckUpdate objContact, "mail", strAddress
	CheckUpdate objContact, "targetAddress", "SMTP:" & strAddress

	strDisplayName = objData(strAddress)(0)

	arrAddresses = objContact.GetEx("proxyAddresses")
	For Each strSMTPAddress in arrAddresses
		If InStr(strSMTPAddress, "SMTP:") Then
			Exit For
		End If
	Next
	If strSMTPAddress <> ("SMTP:" & strAddress) Then
		WriteLog "Updating proxyAddresses Attribute: " &_
			objContact.Get("displayName"), True
		If booTestOnly = False Then
			objContact.Put "proxyAddresses", "SMTP:" & strAddress
			objContact.SetInfo
		End If
	End If
	
	For Each strData in objData(strAddress)(1)
		arrTemp = Split(strData, "=")
		strAttribute = arrTemp(0)
		strValue = arrTemp(1)
		
		CheckUpdate objContact, strAttribute, strValue
	Next
	
	Set objContact = Nothing
End Sub

Sub CheckUpdate(objContact, strAttribute, strValue)
	Dim strCurrentValue

	On Error Resume Next
	strCurrentValue = "" : strCurrentValue = objContact.Get(strAttribute)
	If LCase(strCurrentValue) <> LCase(strValue) Then
		WriteLog "Updating " & strAttribute & " Attribute: " &_
			objContact.Get("displayName") & ": Old: " & strCurrentValue &_
			" New: " & strValue, True
		If booTestOnly = False Then
			Err.Clear
			objContact.Put strAttribute, strValue
			objContact.SetInfo
			If Err.Number <> 0 Then
				WriteLog objContact.Name & ": Error Updating " & strAttribute & " with " & strValue, True
				WriteLog objContact.Name & ": " & Err.Description
			End If
		End If
	End If
	On Error Goto 0
End Sub

Sub DeleteOldContacts
	Dim objTemp, objOU, objSubOU, objContact
	Dim strDN, strDisplayName, strCN

	WriteLog "Checking for Old Contacts", False

	Set objTemp = CreateObject("Scripting.Dictionary")
	
	Set objOU = GetObject("LDAP://" & strOrgUnit)
	objOU.Filter = Array("contact")
		
	For Each objContact in objOU
		strDN = objContact.Get("distinguishedName")
		strDisplayName = objContact.Get("displayName")
		objTemp.Add strDN, strDisplayName
	Next
	Set objOU = Nothing

	For Each strDN in objTemp
		If objContactList.Exists(strDN) Then
			objTemp.Remove(strDN)
		End If
	Next

	intDeleted = objTemp.Count

	For Each strDN in objTemp
		Set objContact = GetObject("LDAP://" & strDN)
		strCN = objContact.Name
		Set objOU = GetObject(objContact.Parent)
		Set objContact = Nothing

		WriteLog "Deleting Contact: " & objTemp(strDN), True
		If booTestOnly = False Then
			objOU.Delete "contact", strCN
		End If
		
		Set objOU = Nothing
	Next
	Set objTemp = Nothing
	
	WriteLog "Completed Checking Old Contacts", False
End Sub

'
' Main Code
'

' Global Variables

Dim objFileSystem, objData, objLogFile, objContactList
Dim strTimeStamp, strLogFile, strFileName, strFileDelimiter, strDisplayNameFormat, strOrgUnit, strFields
Dim intRead, intDiscarded, intCreated, intUpdated, intDeleted
Dim booReadHeader, booSkipHeader, booTestOnly
Dim arrTemp

' Object Initialisation

Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Set objData = CreateObject("Scripting.Dictionary")

' Log File Init

strTimeStamp = CStr(Now())
strTimeStamp = Replace(strTimeStamp, "/", "")
strTimeStamp = Replace(strTimeStamp, " ", "")
strTimeStamp = Replace(strTimeStamp, ":", "")
If Not objFileSystem.FolderExists("Logs") Then
	objFileSystem.CreateFolder("Logs")
End If
arrTemp = Split(WScript.ScriptName, ".")
strLogFile = "Logs\" & arrTemp(0) & strTimeStamp & ".log"
Set objLogFile = objFileSystem.OpenTextFile(strLogFile, 2, True, 0)

SortArgv

WriteLog "Script Started", False
If booTestOnly = True Then
	WriteLog "** Running in Test Mode **", False
End If

intDiscarded = 0

ReadSource(strFileName)
CheckADData

Set objContactList = CreateObject("Scripting.Dictionary")

SyncContacts

Set objContactList = Nothing

WriteLog "Script Completed", False
WriteLog "Records Read: " & intRead & " Records Discarded: " & intDiscarded, False
WriteLog "Contacts Created: " & intCreated & " Contacts Checked for Updates: " & intUpdated, False
WriteLog "Contacts Deleted: " & intDeleted, False

Set objLogFile = Nothing
Set objData = Nothing
Set objFileSystem = Nothing