Лабораторная работа 2.1

Получение информации о пользователях с почтовым ящиками в домене

Запрос ADSI для получения информации о почтовых ящиках Exchange Server, обнаружение всех почтовых ящиков Exchange Server в домене Active Directory, применение свойства mailNickName

Задание:

1. Создайте в том же файле "Обработка почтовых ящиков.xls" в Excel новую процедуру с именем MailboxListing().
2. Напишите для этой процедуры программный код, который бы:

• проводил поиск по домену nwtraders1.msft и находил всех пользователей, для которых на Exchange Server имеются почтовые ящики;
• выводил бы в окно Immediate информацию об имени данного пользователя, пути к объекту данного пользователя в Active Directory и псевдониме его почтового ящика;

3. Измените процедуры MailboxListing() и MailboxProcessing() таким образом, чтобы процедура MailboxListing производила передачу псевдонима почтового ящика для пользователей в виде параметра, и, таким образом, в базу данных записывалась бы информация о всех сообщениях во всех почтовых ящиках.

Решение:

К пункту 2 — вывод информации о пользователях домена с почтовыми ящиками в окно Immediate:

Код процедуры MailBoxListing() может быть таким:

Public Sub MailboxListing()

Dim con As New ADODB.Connection

Dim rs As New ADODB.Recordset

Dim com As New ADODB.Command

con.Provider = "ADsDSOObject"

con.Properties("ADSI Flag") = 1

con.Open "Active Directory Provider"

Set com.ActiveConnection = con

com.CommandText = "<LDAP://DC=nwtraders1,DC=msft>;" & _

"(&(objectClass=user)(mailNickName=*));displayName, AdsPath, mailNickname;subTree"

Set rs = com.Execute

Do While rs.EOF = False

    Debug.Print rs.Fields("displayName").Value & vbTab & rs.Fields("adsPath").Value & vbTab & rs.Fields("mailNickName").Value

    rs.MoveNext

Loop

End Sub

К пункту 3  — передача информации об именах пользователей процедуре MailboxProcessing() для обработки почтовых ящиков:

Код процедур MailboxListing() и MailboxProcessing() после внесения измененйи может выглядеть так:

Public Sub MailboxListing()

Dim con As New ADODB.Connection

Dim rs As New ADODB.Recordset

Dim com As New ADODB.Command

con.Provider = "ADsDSOObject"

con.Properties("ADSI Flag") = 1

con.Open "Active Directory Provider"

Set com.ActiveConnection = con

com.CommandText = "<LDAP://DC=nwtraders1,DC=msft>;" & _

"(&(objectClass=user)(mailNickName=*));displayName, AdsPath, mailNickname;subTree"

Set rs = com.Execute

Do While rs.EOF = False

     Call MailboxProcessing(rs.Fields("mailNickName").Value)

    rs.MoveNext

Loop

End Sub

Sub MailboxProcessing(sMailboxAlias As String)

Dim sURL As String

sURL = "file://./backofficestorage/nwtraders1.msft/mbx/" & sMailboxAlias

Dim cn As New ADODB.Connection

cn.Provider = "ExOLEDB.DataSource"

cn.ConnectionString = sURL

'On Error GoTo ErrorHandler

cn.Open

On Error GoTo 0

Dim sSQL As String

sSQL = "SELECT ""DAV:displayname"", ""http://schemas.microsoft.com/exchange/outlookmessageclass"", " & _

"""http://schemas.microsoft.com/mapi/proptag/x0e080003"", ""DAV:href"", ""DAV:parentname"", " & _

"""DAV:creationdate"", ""DAV:getlastmodified"", ""DAV:lastaccesssed"" " & _

"FROM SCOPE ('DEEP TRAVERSAL OF """ & sURL & """') WHERE ""DAV:isfolder"" = False"

'sSQL = "SELECT ""http://schemas.microsoft.com/mapi/proptag/x0e080003"", ""DAV:href"", ""DAV:hassubs"", ""DAV:displayname"" " & _

   "FROM SCOPE ('SHALLOW TRAVERSAL OF """ & sConnString & """') WHERE ""DAV:isfolder"" = true"

Dim rs As New ADODB.Recordset

rs.LockType = adLockOptimistic

rs.CursorType = adOpenStatic

rs.Open sSQL, cn

Dim cnAccess As New ADODB.Connection

cnAccess.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\MailboxContents.mdb;Persist Security Info=False"

cnAccess.Open

Dim com As New ADODB.Command

com.CommandText = "Create Table Mailboxes " & _

"(MailboxAlias Char, MessageName Char, MessageType Char, " & _

"MessageSize integer, MessageUrl text, ParentFolderUrl text," & _

"CreationDate Datetime, ModificationDate Datetime, AccessedDate Datetime)"

com.ActiveConnection = cnAccess

On Error Resume Next

com.Execute

If cnAccess.Errors.Count = 0 Or cnAccess.Errors(0).SqlState = 3010 Then

    GoTo mbProc

Else

    Exit Sub

End If

On Error GoTo 0

mbProc:

On Error GoTo 0

Dim rsAccess As New ADODB.Recordset

rsAccess.LockType = adLockOptimistic

rsAccess.CursorType = adOpenStatic

rsAccess.Open "select * from Mailboxes", cnAccess

Do While rs.EOF = False

    rsAccess.AddNew

    rsAccess.Fields("MailboxAlias").Value = sMailBoxAlias

    rsAccess.Fields("MessageName").Value = rs.Fields("DAV:displayname").Value

    rsAccess.Fields("MessageType").Value = rs.Fields("http://schemas.microsoft.com/exchange/outlookmessageclass").Value

    rsAccess.Fields("MessageSize").Value = rs.Fields("http://schemas.microsoft.com/mapi/proptag/x0e080003").Value

    rsAccess.Fields("MessageUrl").Value = rs.Fields("DAV:href").Value

    rsAccess.Fields("ParentFolderUrl").Value = rs.Fields("DAV:parentname").Value

    rsAccess.Fields("CreationDate").Value = rs.Fields("DAV:creationdate").Value

    rsAccess.Fields("ModificationDate").Value = rs.Fields("DAV:getlastmodified").Value

    rsAccess.Fields("AccessedDate").Value = rs.Fields("DAV:lastaccesssed").Value

    rsAccess.Update

    rs.MoveNext

Loop

Exit Sub

ErrorHandler:

Dim ADOError As ADODB.Error

For Each ADOError In cn.Errors

    MsgBox ADOError.NativeError & vbCrLf & ADOError.Description

Next

End Sub

Получить учебные материалы по этому курсу