VBS - Kontakte im ADS anlegen

'Allgemeine Informationen / Hinweise / ChangeLog  
'##########################################################################  
'Autor:	Dani  
'Aufagbe:	Aus einer Exceltabelle im Exchange externe Kontakt erstellen  
'  
'Version:  
'0.1 - Namensgebung einheitlich dargestellt  
'0.2 - Dialogbox zur Abfrage der Exceltabelle eingebaut  
'0.3 - Überprüft, ob Kontakt schon vorhanden ist  
'0.4 - In der Abfrage, ob die E-Mailadresse schon AD vorhanden ist, war  
'      die Abfrage falsch.  
'  
'  
'Variablen  
'##########################################################################  
Dim objobjExcel, objOpenDialog, objOU, objContact, objRecip
Dim strVorname, strNachname, strEmail, strDesc
'  
'  
' Dialogbox - Auswahl der Exceltabelle, die eingelesen werden soll  
'##########################################################################  
do
Set objOpenDialog = CreateObject("SAFRCFileDlg.FileOpen")  
intReturn = objOpenDialog.OpenFileOpenDlg
'  
If intReturn Then
'  
Else
WScript.Echo "Script wird beendet!"  
WScript.Quit
End If
Loop While objOpenDialog.FileName = ""   
'  
'  
'Die entsprechende Datei wird geöffent  
'##########################################################################  
Set objExcel = WScript.CreateObject("Excel.Application")  
objExcel.Workbooks.Open objOpenDialog.FileName
'  
'Zeilennummer der ersten Datenzeile  
i = 2 
Do While objExcel.Worksheets(1).Cells(i,3).Value <> ""  
strVorname 	= objExcel.Worksheets(1).Cells(i,1).Value
strNachname = objExcel.Worksheets(1).Cells(i,2).Value
strEmail 	= objExcel.Worksheets(1).Cells(i,3).Value
strDesc 	= objExcel.Worksheets(1).Cells(i,4).Value
'	  
'	  
' Organisationseinheit, in der ide Kontake erzeugt werden sollen  
Set objOu = GetObject("LDAP://ou=Kontakte,dc=familie-wydler,dc=local")  
	

'Überprüfen, ob eine Kontakt schon vorhanden ist und setzt dem entsprechend die Variable  
' True - E-Mailadresse existiert bereits  
' False - E-Mailadresse nicht vorhanden  
emailExists = False
For Each adcontact In objOu
If LCase(CStr(adcontact.targetAddress)) = LCase(CStr("SMTP:"& strEmail)) Then  
emailExists = True
Exit For
End If
Next
'  
'Erzeugt die einzelnen Kontakte  
If Not emailExists Then
'	  
'Erzeugt die einzelnen Kontakte  
Set objContact = objOu.Create("contact", "cn="& strVorname &" "& strNachname)	  
objContact.mailNickName = strVorname &" "& strNachname  
objContact.displayName = strVorname &" "& strNachname  
objContact.targetAddress = strEmail
objContact.givenName = strVorname 
objContact.sn = strNachname 
'  
'Setzt nur die Beschreibung, wenn das Excelfeld nicht leer ist  
If strDesc <> "" Then  
objContact.description= strDesc
End If
'	  
'Hinterlegt im Reiter "E-Mail Adressen" der Benutzereigenschaften die E-Mailadresse  
Set objRecip = objContact
objRecip.MailEnable "SMTP:" & strEmail  
'  
objContact.SetInfo
Else
WScript.echo "Doppelter Kontakt - "& strVorname &", "& strNachname &"!"  
End If
'	  
'Nächste Excelzeile  
i = i + 1
Loop
'  
'Setzt das "gespeichert" - Flag. Somit entfällt die Abfrage beim Beenden  
objExcel.ActiveWorkbook.Saved = True
'  
'Exceltabelle schließen / beenden  
objExcel.Application.Quit
'  
'  
'Script beenden  
'##########################################################################  
WScript.Echo "Kontakte erfolgreich angelegt!"  
WScript.Quit