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

Экспорт вложений из почтового ящика Exchange Server

Выгрузка вложений из почтовых ящиков хранилищ Exchange Server в файловую систему, протоколирование информации об обнаруженных вложениях в базу данных, применение ADO/Exchange OLE DB Provider, CDOEX и Scripting.Runtime

Задание:

Измените созданный на предыдущий лабораторной работе код таким образом, чтобы:

• каждое вложение экспортировалось бы как обычный файл в созданный каталог приложения;
• информация о каждом экспортируемом вложении записывалась бы в файл MailBoxContens.mdb. В этом файле должна быть создана таблица Attachments со следующими полями (ее можно создать вручную):

Решение:

Соответствующий код может бть таким:

Dim sAttachExportFolder As String

Dim sMbxAlias As String

Sub ProcMailBox()

'Присваиваем значение корневому каталогу для экспорта вложений

sAttachExportFolder = "E:\MailExport"

'переменная для псевдонима почтового ящика

'переменная для имени домена в формате "nwtraders1.msft"

Dim sDomainName As String

'Присваиваем значения переменным

sMbxAlias = "Admin"

sDomainName = "nwtraders1.msft"

'Создаем на диске каталог почтового ящика для экспорта

Dim oFSO As New Scripting.FileSystemObject

Dim oFolder As Scripting.Folder

On Error Resume Next

Set oFolder = oFSO.CreateFolder(sAttachExportFolder & "\" & sMbxAlias)

If Err.Number = 58 Then

    Set oFolder = oFSO.GetFolder(sAttachExportFolder & "\" & sMbxAlias)

End If

On Error GoTo 0

    'Переменная для строки подключения к хранилищу

Dim sConnString As String

Debug.Print oFolder.Path

sConnString = "file://./backofficestorage/" & sDomainName & "/MBX/" & sMbxAlias & "/"

    'Debug.Print sConnString

    'Запускаем процедуру RecurseFolder

Call RecurseFolder(sConnString, oFolder.Path)

End Sub

Sub RecurseFolder(sConnString As String, sFolderPath As String)

'Создаем объекты для создания каталогов

Dim oFSO As New Scripting.FileSystemObject

Dim oFolder As Scripting.Folder

'Создаем объект соединения

Dim cn As New ADODB.Connection

'Настраиваем свойство Provider и подключаемся, используя

'полученную в качестве параметра строку подключения

cn.Provider = "Exoledb.DataSource"

cn.Open sConnString

'Создаем переменную с запросом к хранилищу Exchange Server

Dim sSQL As String

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"

'sSQL = "SELECT * " & _

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

'Debug.Print sSQL

'Итого запрос выглядит как

'SELECT "http://schemas.microsoft.com/mapi/proptag/x0e080003", "DAV:href", "DAV:hassubs"

'FROM SCOPE ('SHALLOW TRAVERSAL OF "file://./backofficestorage/nwtraders1.msft/MBX/Admin/"') WHERE "DAV:isfolder" = true

' Поле "http://schemas.microsoft.com/mapi/proptag/x0e080003" означает размер папки в байтах

'"DAV:href" возвращает путь к папке в формате "file://./backofficestorage/nwtraders1.msft/MBX/Admin/TestFolder"

'"DAV:hassubs" возвращает 0 (False), если подпапок нет, и -1 (true), если они есть

'shallow traversal - только этот уровень (не заходя вглубь)

'Создаем объект Recordset для хранения информации о сообщениях и вложениях

Dim rs As New ADODB.Recordset

'Определяем меcтонахождение курсора на сервере

rs.CursorLocation = adUseServer

rs.Open sSQL, cn

'Проверяем, что в recordset

'Debug.Print rs.GetString()

'Проходим циклом по Recordset и для каждой папки запускаем процедуру ProcFolder

' а каждой вложенной папки заново запускаем процедуру RecurseFolder

Do While rs.EOF = False

'Создаем папку или получаем на нее ссылку, если она уже есть

On Error Resume Next

Set oFolder = oFSO.CreateFolder(sFolderPath & "\" & rs.Fields("DAV:displayname").Value)

If Err.Number = 58 Then

    Set oFolder = oFSO.GetFolder(sFolderPath & "\" & rs.Fields("DAV:displayname").Value)

End If

On Error GoTo 0

    Call ProcFolder(rs.Fields("DAV:href").Value & "/", oFolder.Path)

    'Debug.Print rs.Fields("DAV:href").Value & "/"

    If rs.Fields("DAV:hassubs").Value = True Then

        Call RecurseFolder(rs.Fields("DAV:href").Value, oFolder.Path)

    End If

rs.MoveNext

Loop

rs.Close

cn.Close

End Sub

Sub ProcFolder(sFolderURL As String, sFolderPath As String)

'Создаем объекты для создания каталогов

Dim oFSO As New Scripting.FileSystemObject

Dim oFolder As Scripting.Folder

'Создаем объекты Recordset - для сообщений в папке и Record - для самой папки

Dim rs1 As New ADODB.Recordset

Dim rec1 As New ADODB.Record

'Объект record удобно использовать для открытия соединения и передачи информации о нем

'для объекта RecordSet

rec1.Open sFolderURL, , adModeReadWrite

'Объявляем и создаем запрос для Recordset, в котором будет находиться список

'всех сообщений в данной папке, у которых есть вложения

Dim sSQL1 As String

sSQL1 = "SELECT ""DAV:href"", ""DAV:contentclass"", ""DAV:displayname"" FROM scope('shallow traversal of """ & sFolderURL & """') " & _

" Where ""DAV:isfolder"" = false AND ""urn:schemas:httpmail:hasattachment"" = true AND ""DAV:ishidden"" = false "

'Debug.Print sSQL1

'А теперь заполняем Recordset

'Каждая запись в нем - сообщение с вложением

rs1.CursorLocation = adUseClient

rs1.CursorType = adOpenStatic

rs1.Open sSQL1, rec1.ActiveConnection

'Напускаем на каждое сообщение с вложением процедуру ProcMail

If rs1.RecordCount <> 0 Then

    rs1.MoveFirst

    Do While rs1.EOF = False

'Очищаем имена сообщений от служебных символов

Dim sTempName As String

sTempName = rs1.Fields("DAV:displayname").Value

sTempName = Replace(sTempName, ":", "")

'Создаем или получаем ссылку на каталог с именем, соответствующим имени сообщения с вложением

On Error Resume Next

Set oFolder = oFSO.CreateFolder(sFolderPath & "\" & sTempName)

If Err.Number = 58 Then

    Set oFolder = oFSO.GetFolder(sFolderPath & "\" & sTempName)

End If

On Error GoTo 0

        Call ProcMail(rs1.Fields("DAV:href").Value, oFolder.Path)

        rs1.MoveNext

    Loop

End If

rs1.Close

End Sub

Sub ProcMail(sMessageURL As String, sSavePath)

Dim cn As New ADODB.Connection

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

cn.Open

Dim rs2 As New ADODB.Recordset

rs2.LockType = adLockOptimistic

rs2.CursorType = adOpenStatic

rs2.Open "Attachments", cn

'Получаем объект CDO.Message для каждого сообщения с вложением

Dim oMessage As New CDO.Message

oMessage.DataSource.Open sMessageURL

'Получаем коллекцию вложений из сообщений

Dim oAttachs As CDO.IBodyParts

Set oAttachs = oMessage.Attachments

'Debug.Print oMessage.TextBody

Dim oAttach As CDO.IBodyPart

For Each oAttach In oAttachs

    oAttach.SaveToFile sSavePath & "\" & oAttach.FileName

    Debug.Print sSavePath & "\" & oAttach.FileName

    rs2.AddNew

    rs2.Fields("MailboxAlias").Value = sMbxAlias

    rs2.Fields("Attachment").Value = oAttach.FileName

    rs2.Fields("FilePath").Value = sSavePath & "\" & oAttach.FileName

    rs2.Fields("MessagePath").Value = sMessageURL

    rs2.Update

Next

End Sub

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