Create Contact Objects in AD in Batch with a Simple VB Script

I have come across a few occasions that I need to create a list of Contact objects for external email addresses in our Active Directory. Most of the time, I ask them to give me the name list in the electronic form. I would then export it to a table to my Access database. I have written a few lines of VB code in this Access database. What it does is that it reads the information from the table and creates Contact objects in the AD.

Here is the code. (Sorry about the indenting. It does not work very well here.)

Private Sub cmdAddContact_Click()

Dim objNewContact ' New Contact to create.
Dim objADAMPath ' Active Directory Application Mode - needed for binding to AD
Dim sPath

sPath =”LDAP:// ou=AddressBook,dc=allaboutexchange, dc=net" ‘where I put all the new Contacts

Dim fName
Dim lName
Dim email
Dim displayname

Dim rsAdContact As Recordset
Dim adContactSQL
Set dbs = CurrentDb

adContactSQL = "Select * From ContactList" ‘ContactList is the table name
Set rsAdContact = CurrentDb.OpenRecordset(adContactSQL, dbOpenDynaset)

Do Until rsAdContact.EOF Or rsAdContact.BOF

fName = rsAdContact("FirstName")
lName = rsAdContact("LastName")
displyname = rsAdContact("DisplayName")
email = rsAdContact("Email1Address")

Set objADAMPath = GetObject(sPath)
sCN = fName & " " & lName & "."
Set objNewContact = objADAMPath.CREATE("Contact", "CN=" & sCN)
If lName <> "" And lName <> vbNullString Then
objNewContact.Put "sn", lName
End If

If fName <> "" And fName <> vbNullString Then
objNewContact.Put "givenName", fName
End If

If email <> "" And email <> vbNullString Then
objNewContact.Put "mail", email
End If

If displyname <> "" And displyname <> vbNullString Then
objNewContact.Put "mailNickname", displyname
End If

If displyname <> "" And displyname <> vbNullString Then
objNewContact.Put "displayName", displyname 'This appears in the GAL
End If

If email <> "" And email <> vbNullString Then
objNewContact.Put "targetAddress", "SMTP:" & email
End If

objNewContact.SetInfo
objNewContact.SetInfo
rsAdContact.MoveNext
Loop

Set objNewContact = Nothing
Set objADAMPath = Nothing

End Sub

Just one more thing, when you run this Access application, you need to have the domain administrator permission to run since you are creating new AD objects.