Exchange-Kontakte per VBS importieren

'##########################################################################
'Autor: Dani
'Aufgabe: 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("<a href="ldap://ou=Kontakte,dc=familie-wydler,dc=local">LDAP://ou=Kontakte,dc=domain,dc=local</a>")
 
'Ü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:"&amp; 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="&amp; strVorname &amp;" "&amp; strNachname)
objContact.mailNickName = strVorname &amp;" "&amp; strNachname
objContact.displayName = strVorname &amp;" "&amp; strNachname
objContact.targetAddress = strEmail
objContact.givenName = strVorname
objContact.sn = strNachname
 
'Setzt nur die Beschreibung, wenn das Excelfeld nicht leer ist
If strDesc &lt;&gt; "" Then
objContact.description= strDesc
End If
 
'Hinterlegt im Reiter "E-Mail Adressen" der Benutzereigenschaften die E-Mailadresse
Set objRecip = objContact
objRecip.MailEnable "SMTP:" &amp; strEmail
objContact.SetInfo
Else
WScript.echo "Doppelter Kontakt - "&amp; strVorname &amp;", "&amp; strNachname &amp;"!"
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