Red Line Software - we help you manage the efficiency of your office operations.

Introduction

In my article Using Exchange 2000 as a low end contact management solution I presented a way of using Active Directory to search for contacts. Active Directory, once it is extended by Exchange, provides a scalable solution for looking up contacts using the LDAP protocol. Resolving contact names using Outlook when accessing Active Directory is really fast, even if you have hundreds of contacts, and doesn't slow down the way it does when you have too many contacts in an Outlook contacts public folder.

On the other hand Outlook contacts folders are really easy to use. You can import information from a lot of sources using the Import and Export wizard without much hassle. Any application which supports exports of its contacts to a text file can be exported to Outlook because you can always rearrange the contact field to match those of Outlook.

While Active Directory provides the LDIFDE  and CSVDE utilities for importing bulk information, they are not really the easiest conversion utilities that one could hope for.

I will present here some useful scripts for migrating contacts from Outlook to Active Directory. For you, it can be a two part process. For example, if you need to migrate 70,000 contacts from Outlook Express, you can first export them to Outlook, and then use my scripts to transport them to Active Directory.

Contact Migration Script

My script, written in VBScript language has the following requirements. It assumes you've placed the contacts in a Public Folder named "Company Contacts", but you can change the line that begins with  "Set myfolder = myNameSpace.Folders" to point to whichever Outlook folder suits you.

You will need to change the line that begins with "Set objContainer =" so that it will point to an existing Organization Unit (OU) where the Contacts will be placed. To do this, replace the part that says "OU=:.,DC=:." with the distinguishedName attribute of the OU. This property can be found by using the support tools utility ADSIEdit.

For the script to work properly you would also require the "countrycodes.csv" file downloaded here. This file allows Active Directory to register a contact's country with its country code.

The script goes through all the contacts in the Public Folder, checks to see whether the contact already exists and if not creates the contact. It goes through all the contact fields and if a contact property exists it is translated to its Active Directory equivalent.

A couple of issues came up while writing this script. The main one was what to do with duplicate contacts, or contacts with same name. The primary check is to see whether the e-mail address exists. If it does not and the contact name already exist (as determined by the DNExists function), the company name is added to the directory name of the new contact.

The script migrates only the business address. You can customize the script to add the home address but know that the Active Directory Users and Computers snap-in does not show this address at this point.

'ContactMigationScript.vbs
Dim objRecip

'On Error Resume Next

     Set fs = CreateObject("Scripting.FileSystemObject")

     Set myOlApp = CreateObject ("Outlook.Application")

     Set myNameSpace = myOlApp.Application.GetNamespace("MAPI")

'Get the Public Folder containing the contacts

     Set myfolder = myNameSpace.Folders("Public Folders"). _

     Folders("All Public folders").Folders("Public Contacts")

'Open a test file for reporting putposes

     Set reportfile = fs.CreateTextFile ("c:contactreport.txt")

'Look for all contacts in the Public Folder

     For I = 1 To myfolder.Items.Count

     If TypeName(myfolder.Items.Item(I)) = "ContactItem" Then

     Set outlookcontact = myfolder.Items(I)

'Fix the FileAs field so it won't contain Linefeeds.

     FixedFileAs = Replace (outlookcontact.FileAs,Chr(13)," - ")

'Get the Public Contacts OU

     Set objContainer=GetObject(LDAP://OU=Public Contacts,DC=company,DC=com)

     TestforContact = False

'Check to see if the e-mail address already exists

     For Each adcontact In objContainer

     If (CStr (outlookcontact.Email1Address) <> "") And _

     (CStr(adcontact.mail) = CStr (outlookcontact.Email1Address)) Then _

     TestforContact = True

'Check to see whether this is a new contact with an existing name, but from a different company

     (CStr (adcontact.displayName) = FixedFileAs) And _

     (CStr (outlookcontact.CompanyName) = CStr (adcontact.company)) Then _ 

     TestforContact = True

     Next

'Create a valid directory name for the contact. 

     CNName = "CN=" & outlookcontact.FullName

     stAddCompany = ""

     If DNExists (CNNAME) Then

     If outlookcontact.CompanyName = "" Then

     TestforContact = True 

     Else 

'If the directory name exists add the company name to it.

     CNName="CN="&outlookcontact.FullName&"("&outlookcontact.CompanyName& ")"

     If DNExists (CNNAME) Then TestforContact = True

     End If           

     End If            
     If TestforContact = False then 

        'Create a Contact

        Reportfile.WriteLine "Creating: " & FixedFileAs

        Set objContact = objContainer.Create("contact", CNName)

        'Now fill the contact attributes in Active Directory

        With objContact

        .Put "displayName", FixedFileAs

        If outlookcontact.LastName <> "" Then _

        .Put "sn",CStr(outlookcontact.LastName)

        If outlookcontact.FirstName <> "" Then _

        .Put "givenName",CStr(outlookcontact.FirstName)

        If outlookcontact.CompanyName <> "" Then _ 

        .Put "company" , CStr(outlookcontact.CompanyName)

        If outlookcontact.Department <> "" Then _ 

        .Put "department" , CStr(outlookcontact.department)

        If outlookcontact.BusinessAddressCity <> "" Then _

        .Put "l", CStr(outlookcontact.BusinessAddressCity)

        If outlookcontact.Title <> "" Then _ 

        .Put "title", CStr(outlookcontact.Title)

        If outlookcontact.WebPage <> "" Then _

        .Put "wWWHomePage", CStr(outlookcontact.WebPage)

        If outlookcontact.Department <> "" Then _

        .Put "department", CStr(outlookcontact.Department)

        If outlookcontact.BusinessAddressStreet <> "" Then _

        .Put "streetAddress", CStr(outlookcontact.BusinessAddressStreet)

        If outlookcontact.BusinessAddressPostOfficeBox <> "" Then _

        .Put "postOfficeBox",CStr(outlookcontact.BusinessAddressPostOfficeBox)

        If outlookcontact.BusinessAddressPostalCode <> "" Then _

        .Put "postalCode", CStr(outlookcontact.BusinessAddressPostalCode)

        If outlookcontact.BusinessAddressState <> "" Then _ 

        .Put "st" , CStr(outlookcontact.BusinessAddressState)

        If outlookcontact.BusinessAddressCountry <> "" Then 

        .Put "co", CStr(outlookcontact.BusinessAddressCountry)

'Open a file containing table of Country Name, Country designation (two characters) and Country Code

'(Numberical code like the one used for dialing)

        Set codes = fs.OpenTextFile("c:countrycodes.csv")

        Do While not codes.AtEndOfStream

        countryst = codes.ReadLine

        countryar = Split (countryst,",")

        If countryar(0)= CStr(outlookcontact.BusinessAddressCountry) Then

        .Put "c",  countryar (1)

        .Put "countryCode", CInt(countryar(2))

        End If

        Loop 

        End If

        If outlookcontact.BusinessTelephoneNumber <> "" Then _

        .Put "telephoneNumber" ,  CStr(outlookcontact.BusinessTelephoneNumber)

        If outlookcontact.HomeTelephoneNumber <> "" Then _

        .Put "homephone" ,  CStr(outlookcontact.HomeTelephoneNumber)

        If outlookcontact.PagerNumber <> "" Then _ 

        .Put "pager" , CStr(outlookcontact.PagerNumber)

        If outlookcontact.MobileTelephoneNumber <> "" then _

        .Put "Mobile", CStr(outlookcontact.MobileTelephoneNumber)

'Create the mailNickname (alias) attribute from the e-mail and mail-enable the contact.

        If outlookcontact.Email1Address <> "" Then

        Set objRecip = objContact

        TempAr = Split (outlookcontact.Email1Address,"@")

        objRecip.mailNickname = TempAr (0) & "at" & TempAr (1)

        FwdAddress = "SMTP:" & outlookcontact.Email1Address

        objRecip.MailEnable FwdAddress

        End If 

        .SetInfo

        End With

     Else

        Reportfile.WriteLine "Ignoring " & FixedFileAs 

     End If

     End If

Next
Reportfile.close
Function DNExists (dn)

'Determines if a directory name exists by querying Active Directory using LDAP 

        DNExists = False 

        Set rootDSE=GetObject(LDAP://RootDSE)

        DomainContainer = rootDSE.Get("defaultNamingContext")

        Set conn = CreateObject("ADODB.Connection")

        conn.Provider = "ADSDSOObject"

        conn.Open "ADs Provider"

ldapStr="<LDAP://"&DomainContainer&">;(&(cn="&Mid(dn,4) &"));adspath;subtree"

        Set rs = conn.Execute(LDAPStr)

        If rs.RecordCount = 1 Then DNExists = True

        conn.Close

End Function

The most important and somewhat tricky property of them all is the e-mail address. In Active Directory, a contact is assigned a single e-mail address. It is also assigned an Exchange "alias", now called "mailNickname". This property has no real functionality for contacts but it has to be unique in Active Directory for the contact to be created. In the script I create this property by replacing the "@" symbol with the word "at" but it can be any other unique name.
This script cannot migrate more than the first e-mail. A contact needs to be stamped by Exchange before you can add more e-mail addresses, so I provide a second script which should be run after the Exchange RUS has been fired, which usually happens in a range of fifteen minutes after running the contact migration script.

The second script goes through all the contacts in the Public Folder looks for a matching Exchange stamped contact created earlier and adds the e-mail address. Outlook supports three e-mail addresses per contact but I assumed two will suffice. If you need all three e-mail addresses, simply change the field "Email2Address" to "Email3Address" and run the script again.

'ContactMigationScript.vbs
Dim objRecip

'On Error Resume Next

Set fs = CreateObject("Scripting.FileSystemObject")

Set myOlApp = CreateObject ("Outlook.Application")

Set myNameSpace = myOlApp.Application.GetNamespace("MAPI")

'Open a connection to the Public Contacts public folder

   Set myOlApp = CreateObject("Outlook.Application")

   Set myNameSpace = myOlApp.Application.GetNamespace("MAPI")

   Set myfolder = myNameSpace.Folders("Public Folders"). _

   Folders("All Public folders").Folders("Public Contacts")

'Open a connection to Active Directory

   Set conn = CreateObject("ADODB.Connection")

   conn.Provider = "ADSDSOObject"

   conn.Open "ADs Provider"

'Run through all the contacts in the public folder

   For I = 1 To myfolder.Items.Count

   If TypeName(myfolder.Items.Item(I)) = "ContactItem" Then

   Set mycontact = myfolder.Items(I)

'If a contact has a second e-mail address find the first contact in Active Directory

'by using the first e-mail address      

   If (mycontact.Email2Address <> "") Then

   LDAPStr = "<LDAP://" & DomainContainer & _

   ">;(&(objectCategory=contact)(mail=" _

   & mycontact.Email1Address & "));adspath;subtree"

   Set rs = conn.Execute(LDAPStr)

   If rs.RecordCount = 1 Then

     Set oContact = GetObject(rs.Fields(0).Value)

     Set objRecip = oContact

'Add the second e-mail address to the contact if it is njot already a property of the contact

     sAddress = "smtp:" & mycontact.Email2Address

     bIsFound = False

     vProxyAddresses = objRecip.ProxyAddresses

     nProxyAddresses = UBound(vProxyAddresses)

     nProxyAddress = 0

     Do While nProxyAddress <= nProxyAddresses

       If vProxyAddresses(nProxyAddress) = sAddress Then

       bIsFound = True

       Exit Do

       End If

       nProxyAddress = nProxyAddress + 1

     Loop

     If Not bIsFound Then

     ReDim Preserve vProxyAddresses(nProxyAddresses + 1)

     vProxyAddresses(nProxyAddresses + 1) = sAddress

     objRecip.ProxyAddresses = vProxyAddresses

     oContact.SetInfo

     End If

    End If

   End If

  End If

Next

conn.Close

Converting Distribution Lists

Distribution lists are a very weak link in Outlook. Since Outlook is not really a directory per-se like Active Directory, there is usually some problem with keeping track of where the contacts that belong to the Distribution List exist. Also, when you do an import or export the reference to the contacts is deleted and all that is left is the e-mail address of the contact which is not updated.

Converting the Distribution list requires to create a Universal Distribution Group in Active Directory for each Distribution List and then look for the contacts that already exist in Active Directory, searching according to their e-mail address.

Dim MyDl

    Dim objRecip

    Dim mailar(2)

   'On Error Resume Next
   Set rootDSE=GetObject(LDAP://RootDSE)

   DomainContainer = rootDSE.Get("defaultNamingContext")

   Set fs = CreateObject("Scripting.FileSystemObject")

   Set userFile = fs.CreateTextFile("c:DLConvertReport.txt")

   Set myOlApp = CreateObject("Outlook.Application")

   Set myNameSpace = myOlApp.Application.GetNamespace("MAPI")

'Open a connection to the DLs public folder.

   Set myfolder = myNameSpace.Folders("Public Folders"). _

   Folders("All Public folders").Folders("DLs")

   FindContactinDLs = False

'Go through all the distribution lists in the folder

   For I = 1 To myfolder.Items.Count

   If TypeName(myfolder.Items.Item(I)) = "DistListItem" Then

   Set MyDl = myfolder.Items(I)

'Set the Type of Group as Universal Distribution Group

   lGroupType = &H8 'ADS_GROUP_TYPE_UNIVERSAL_GROUP

'Create the Group
   Set objContainer = GetObject(LDAP://OU=DLs,DC=company,DC=com)

   strGroupName = MyDl.DLName

   Set iAdGroup = objContainer.Create("group", "cn=" + strGroupName)

'Create a login name for the group that conforms to the NT4 standards

   strSamAcctName = "DL" & Replace(strGroupName, " ", "")

   strSamAcctName = Left(strSamAcctName, 12)

'Add a number at the end of login name of the group if it exists

   n = 2

   If LoginNameExists (strSamAcctName) Then _

   strSamAcctName = strSamAcctName & "2"  

   Do While LoginNameExists (strSamAcctName) 

   n = n + 1

   strSamAcctName = Left (strSamAcctName,12) & CStr (n)

   Loop

   iAdGroup.Put "sAMAccountName", strSamAcctName

   iAdGroup.Put "groupType", lGroupType

   userFile.WriteLine "Creating   " & strGroupName

'Flush to the directory

    iAdGroup.SetInfo
'Mail Enable 

   Set iMailGroup = iAdGroup

   iMailGroup.mail = strSamAcctName & "@company.com"

   iMailGroup.MailEnable
'Write Exchange information to the directory.

   iAdGroup.SetInfo

'Look for members of the distribution list in Active Directory

   For y = 1 To MyDl.MemberCount

   Set DLMember =  MyDl.GetMember(y)

   WScript.Echo DLMember.Name & "  " & DLMember.Address 

   If DLMember.Address <> "" Then

   contactMail = MyDl.GetMember(y).Address

   recipient = 

   Set conn = CreateObject("ADODB.Connection")

   conn.Provider = "ADSDSOObject"

   conn.Open "ADs Provider"
   ldapStr = "<LDAP://" & DomainContainer & _ 

   ">;(&(&(objectCategory=contact)(!extensionAttribute1=ShowInGAL)" & _

"(&(&(& (| (&(objectCategory=person)(objectClass=contact))" & _

")))(objectCategory=contact)(proxyAddresses=smtp:" & _

CStr(contactMail) & "))));adspath;subtree"
   Set rs = conn.Execute(ldapStr)

 'If contact is found add it to the corresponding Universal Group          
   If Not rs.EOF Then

   Set oContact = GetObject(rs.Fields(0).Value)

   path = oContact.ADsPath

   If Not (iAdGroup.IsMember(path)) Then

   userFile.WriteLine "  Adding Contact   " & path

   iAdGroup.Add path

   iAdGroup.SetInfo

   End If

   End If

   Else

'If member is a Distribution list itself, look for it in Active Directory

'and add it to the Universal Group

    DLName = MyDl.GetMember(y).Name

    Set conn = CreateObject("ADODB.Connection")

    conn.Provider = "ADSDSOObject"

    conn.Open "ADs Provider"
   ldapStr = "<LDAP://" & DomainContainer _

    & ">;(&(&(&(& (mailnickname=*)(| (objectCategory=group) )))

(objectCategory=group)(displayName=" & DLName & ")));adspath;subtree"
   Set rs = conn.Execute(ldapStr)
   If Not rs.EOF Then

   Set oUDG = GetObject(rs.Fields(0).Value)

   path = oUDG.ADsPath

   userFile.WriteLine "  Adding DL   " & path

   If Not (iAdGroup.IsMember(path)) Then

   iAdGroup.Add path

   iAdGroup.SetInfo

   End If

   End If

   End If

Next

End If

Next
Function LoginNameExists (login)

   'Check to see if login name already exists in Active Directory

   LoginNameExists = False 

   Set rootDSE=GetObject(LDAP://RootDSE)

   DomainContainer = rootDSE.Get("defaultNamingContext")

   Set conn = CreateObject("ADODB.Connection")

   conn.Provider = "ADSDSOObject"

   conn.Open "ADs Provider"

   WScript.Echo login

   ldapStr = "<LDAP://" & DomainContainer & _

   ">;(& (sAMAccountName=" & login & ") );adspath;subtree"

   Set rs = conn.Execute(LDAPStr)

   If rs.RecordCount = 1 Then LoginNameExists = True

   conn.Close

End Function

Conclusion

If the scripts look tricky to you, they are easy to modify to match your Active Directory and e-mail domain. On the other hand, once you learn to master scripting Active Directory and Exchange, the true power of these scripts will reveal itself. The great thing about using a script rather than say a wizard, even a well thought out one like the Outlook Import and Export one is that you get almost absolute flexibility. You can write almost any rule to eliminate unwanted contacts during the migration process. You can decide on whatever naming standard for contacts you choose and make it as complex or as simple as you would like. You can create different contacts in different folders according to any criteria that you choose.  The sky is really the limit when it comes to the power of scripting.

Author: Amit Zinman

Currently working as Project Manager and Systems Consultant, heading and consulting on Exchange and NT/Windows 2000 based migrations and deployments for large companies such as Checkpoint, Comverse, Smarteam, Nice, Aladdin and leading Israeli Banks, Also involved in writing scripts and custom solutions for clients based on ADSI, CDO and Visual Basic and teaching Windows 2000 and Exchange 2000 in MSCE colleges and lecturing in Microsoft User Groups.