Использование скрипта, преобразующего MAPI информации о контактах из Outlook в быстрейшую LDAP-реализацию, расширенную для нужд Exchange.
Введение
В статье Using Exchange 2000 as a low end contact management solution рассказано о способе использования Active Directory для хранения контактов. Расширенный под нужды Exchange, Active Directory предоставляет собой масштабируемые решения для хранения контактов, запрашиваемых средствами LDAP. Процесс получения контактов из Active Directory, даже большого количества, происходит очень быстро, что выгодно отличает его от использования стандартных Outlook контактов.
С другой стороны, обычные контакты Outlook очень легко использовать. Существует возможность импортировать их из множества источников с помощью мастера импорта-экспорта (Import and Export Wizard). Контакты из любого приложения, поддерживающего экспорт в текстовые файлы, могут быть импортированы в Outlook.
Хотя Active Directory и предоставляет утилиты для массового импорта информации (LDIFDE и CSVDE), тем не менее, это не самый лёгкий способ, на который не каждый может надеяться.
Я представлю вашему вниманию несколько полезных скриптов для переноса контактов из Outlook в Active Directory. Это выглядит как процесс из двух частей. Например, вам нужно перенести 70000 контактов из Outlook Express — сначала экспортируйте их, а потом используйте скрипт для переноса их в AD.
Скрипт для переноса контактов
Скрипт, написанный на VBScript, имеет следующие требования:
— Хранение контактов в общей папке (для изменения, поправьте переменную myfolder 'Set myfolder = myNameSpace.Folders');
— Изменение строки, начинающейся с , для того, чтобы objContainer указывал на существующий OU (Organization Unit), куда и будут перенесены контакты. Чтобы осуществить это, замените часть строки на DN вашего OU (используйте утилиту ADSIEdit для нахождения этого свойства)
Также, для правильной работы скрипта, необходим файл «contrycodes.csy», который можно скачать тут. Это позволит распознать страну контакта по её коду.
Скрипт просматривает все контакты в общей папке, проверяет наличие контакта в AD и, при его отсутствии, создаёт оный. Он просматривает все поля в контакте и, если они правильно созданы, переводит в эквивалентные поля AD.
При написании этого скрипта возникли некоторые проблемы. Главный вопрос — что делать с дублирующимися контактами, или контактами с одинаковым названием? Производится основная проверка — существует ли e-mail адрес, если нет, а контакт с таким именем уже создан (что определяется функцией DNExists), то к названию нового контакта добавляется имя компании.
Скрипт переносит только бизнес адреса, но его можно настроить так, чтобы добавлять и домашние. Имейте в виду, что на сегодняшний момент оснастка `Active Directory Users and Computers` не показывает домашние адреса.
'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
If (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 = ";(& (cn=" & Mid (dn,4) & ") );adspath;subtree"
Set rs = conn.Execute(LDAPStr)
If rs.RecordCount = 1 Then DNExists = True
conn.Close
End Function
Самое важное свойство — это e-mail адрес. В Active Directory контакту сопоставлен один почтовый адрес, также присвоен алиас Exchange, называющийся «mailNickname». Это свойство реально не используется, но должно быть уникальным в AD для создаваемых контактов. В скрипте это достигается заменой «@» в адресе почты на «at», но могут быть и другие способы.
Данный скрипт переносит только первый e-mail. Контакты должны быть отмечены Exchange сервером перед тем, как добавлять какие-то дополнительные адреса. Далее представлен скрипт, подлежащий запуску после того, как отработал Exchange RUS(обычно через 15 минут после запуска скрипта переноса).
Второй скрипт просматривает все контакты в Общей Папке, находя соответствующие контакты, отмеченные Exchange'ом, и добавляет e-mail адрес. Outlook поддерживает три адреса на контакт, но я считаю, что хватит и двух. Если вам нужны три e-mail адреса, просто измените поле «Email2Address» на «Email3Address» и запустите скрипт ещё раз.
Dim objRecip
Dim mycontact' As ContactItem
Dim proxies
'On Error Resume Next
Set rootDSE=GetObject(LDAP://RootDSE)
DomainContainer = rootDSE.Get("defaultNamingContext")
'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 = ";(&(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 Перенос списков рассылок
Списки рассылок — слабое место в Outlook. Так как Outlook реально не является директорией (как, например, Active Directory), появляются проблемы с отслеживанием местонахождения того или иного контакта, принадлежащего списку. Также, если вы импортируете или экспортируете ссылки на удалённые контакты, могу возникнуть некоторые проблемы.
Перенос списков требует создания Universal группы в AD для каждого списка и просмотра e-mail адресов существующих контактов AD.
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 = ";(&(&(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 = ";(&(&(&(& (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 = ";(& (sAMAccountName=" & login & ") );adspath;subtree"
Set rs = conn.Execute(LDAPStr)
If rs.RecordCount = 1 Then LoginNameExists = True
conn.Close
End Function
Заключение
Эти скрипты кому-то могут показаться сложными, но их настройка под конкретный домен очень проста. С другой стороны, они являются хорошим стимулом для освоения написания сценариев для AD. Огромный плюс скриптов по сравнению с различными мастерами в том, что вы добиваетесь абсолютной гибкости процесса. Существует возможность написания практически любого правила, как то: не пропустить ненужный контакт при переносе, определить политику создания имён и т.п. Вы можете создавать любые контакты в любых папках, в соответствие какому-то выбранному критерию. Предел только один — ваша фантазия.