none
Скрипт архивирования сообщений Outlook. RRS feed

  • Общие обсуждения

  • 1.    Имеется почтовый ящик в Outlook/Exchange, в котом накапливается поступающая ВСЯ почта. Когда письма могут понадобиться никто не знает. Архивация стандартными средствами не устраивает, так как для поиска конкретного письма необходимо восстанавливать целый архив.

    2.    Решили написать небольшой скрипт, который выбирал бы письма из диапазона дат и раскладывал бы их по папкам в следующей структуре: .\<Год>\<Месяц>\<День>.

    3.    Для отбора писем использовали свойство objItem.CreationTime, так как свойство objItem.ReceivedTime оказалось недоступно из VBS. Если кто-то знает как до данного свойства достучаться – подскажите, пожалуйста.

    4.    Скрипт административный и все основные настройки делаются в теле скрипта. Желающие могут добавить диалоговые окна ввода или распознавание параметров командной строки.

    5.    Если переписать скрипт на JS, то можно упростить процесс формирования имен за счет использования регулярных выражений.

     

    Далее, собственно, скрипт. Буду рад, если он кому-нибудь пригодится J.

     

    '-------------------------------------------------------------------------

    '--- Программа сохранения на диске почтовых сообщений Outlook по датам ---

    '-------------------------------------------------------------------------

    '============ НАЧАЛО ==============

     

    '--- Объявления

    Dim objApp, objNS

    Dim colFolders, objFolder

    Dim ii, tmpStr, tmpErrorStr, tmpExistStr

    Dim iLevel

    Dim strRootBF, strLogFileName

    Dim dStartDate, dEndDate

     

    Dim objFSO

     

    '========== Инициализация диапазона дат архивирования ================

    dStartDate = CDate("01.09.2000")

    dEndDate = CDate("31.12.2004")

    'dEndDate = Now()

     

    '========== Определение пути архивирования почты =====================

    strRootBF = "e:\temp\outlookbackup\"

     

    '--- Инициализация объектов

    Set objApp = CreateObject("Outlook.Application")

    Set objNS = objApp.GetNamespace("MAPI")

    Set objFSO = CreateObject("Scripting.FileSystemObject")

     

    '--- Получаем ссылку на корневую папку почты по умолчанию

    Set objFolder = objNS.GetDefaultFolder(6)                                                           '6 - olFolderInbox

     

    ' Инициализация строки вывода перечня просмотренных папок

    tmpStr=""

    tmpErrorStr=""

    tmpExistStr=""

     

    ' Определение лог-файла (файл будет размещен в корневом каталоге скрипта)

    strLogFileName = CStr(Now())

    strLogFileName = Replace(strLogFileName,".","")

    strLogFileName = Replace(strLogFileName,":","")

    strLogFileName = Replace(strLogFileName," ","-")

    strLogFileName = ".\" & strLogFileName & ".log"

    MsgBox(strLogFileName)

     

    ' Счетчик уровней вложенности папок почты

    iLevel=0

    ' Счетчик кол-ва обработанных почтовых сообщений

    iCounter=0

     

    ' Обращаемся к корневой почтовой папке

    GetFolder(objFolder)

    ' Выводим перечень обработанных папок

    'MsgBox(tmpStr)

     

    ' Формируем лог-файл

    if Not objFSO.FileExists(strLogFileName) then

          objFSO.CreateTextFile(strLogFileName)

    end if     

    ' Открываем лог-файл

    Set objLogFile = objFSO.OpenTextFile(strLogFileName, 8, True)                     ' 8 - ForAppending

     

    ' Заполняем лог-файл

    objLogFile.WriteLine "========== Сохраненные сообщения =========" & VbCrLf

    objLogFile.WriteLine tmpStr

    objLogFile.WriteLine VbCrLf & "========== Несохраненные сообщения =========" & VbCrLf

    objLogFile.WriteLine tmpErrorStr

    objLogFile.WriteLine VbCrLf & "========== Файлы уже существуют =========" & VbCrLf

    objLogFile.WriteLine tmpExistStr

    objLogFile.Close

     

    ' Завершение работы

    Set objApp = Nothing

    Set objNS = Nothing

    Set objFolder = Nothing

    Set objFSO = Nothing

     

    MsgBox("Архивация почтовых сообщений завершена")

    '============ КОНЕЦ ==============

     

    '--------------------------------------------------

    '--- Функция обработки сообщений заданной папки ---

    '--- и перебора вложенных подпапок              ---

    '--------------------------------------------------

    Sub GetFolder(objCurFolder)

          ' Объявляем внутренние переменные

          Dim colFolders

          Dim objFolder

         

          Dim iYear, iMonth, iDay

         

          On Error Resume Next

         

          ' Увеличиваем счетчик уровней папок

          iLevel = iLevel+1

         

          ' Перебираем все элементы папки

          For Each objItem In objCurFolder.Items

                ' Увеличиваем счетчик обработанных почтовых сообщений

                iCounter = iCounter +1

                           

                ' Читаем дату создания сообщения

                iYear = Year(objItem.CreationTime)

                iMonth = Month(objItem.CreationTime)

                iDay = Day(objItem.CreationTime)

                tmpDate = cStr(objItem.CreationTime)

                tmpDate = Replace(tmpDate, ":", "")

                tmpDate = Replace(tmpDate, ".", "")

                tmpDate = Replace(tmpDate, " ", "-")

               

                ' Запоминаем время создания сообщения для фильтрации

                curTime = objItem.CreationTime

               

                ' Проверяем условия фильтрации сообщений по дате создания

                If (curTime>=dStartDate) AND (curTime<=dEndDate) Then

     

                      tmpSenderAddress = objItem.SenderEmailAddress

                      tmpSenderAddress = Replace(tmpSenderAddress, ".", "-") & "_"

                     

                      ' Проверяем наличие подкаталога и, в случае необходимости, создаем его

                      tmpPath = strRootBF & ConvertString(iYear,4,"_")

                      if Not objFSO.FolderExists(tmpPath) then objFSO.CreateFolder(tmpPath)

                      tmpPath = tmpPath & "\" & ConvertString(iMonth,2,"0")

                      if Not objFSO.FolderExists(tmpPath) then objFSO.CreateFolder(tmpPath)

                      tmpPath = tmpPath & "\" & ConvertString(iDay,2,"0")

                      if Not objFSO.FolderExists(tmpPath) then objFSO.CreateFolder(tmpPath)

                     

                      ' Формируем имена файлов и

                      ' очищаем их от паразитных символов

                      ' (для формирования имени файла используем

                      '  адрес отправителя,

                      '  первые 60 символов темы письма

                      '  и строку, полученную из даты, времени)

                      tmpName = Left(objItem.Subject,60) & "_" & tmpDate

                      tmpName = Replace(tmpName, ":", "_")

                      tmpName = Replace(tmpName, ",", "_")

                      tmpName = Replace(tmpName, ";", "_")

                      tmpName = Replace(tmpName, "\", "_")

                      tmpName = Replace(tmpName, "/", "_")

                      tmpName = Replace(tmpName, ".", "_")

                      tmpName = Replace(tmpName, " ", "_")

                     

                      tmpName = tmpPath & "\" & tmpSenderAddress & tmpName & ".msg"

                     

                      ' Избавляемся от ненужных символов подчеркивания

                      tmpName = Replace(tmpName, "______", "_")

                      tmpName = Replace(tmpName, "_____", "_")

                      tmpName = Replace(tmpName, "____", "_")

                      tmpName = Replace(tmpName, "___", "_")

                      tmpName = Replace(tmpName, "__", "_")

                     

                      ' Проверяем наличие сохраненного файла (на всякий случай :))

                      If Not objFSO.FileExits(tmpName) Then

                            ' Сохраняем сообщение по указанному пути

                            objItem.SaveAs tmpName,3           'olMSG

     

                            ' Проверяем наличие сохраненного файла

                            If objFSO.FileExits(tmpName) Then

                                 tmpStr = tmpStr & tmpName & " - Сохранен" & VbCrLf

     

                                 ' УДАЛЯЕМ СООБЩЕНИЕ !!!

                                 objItem.Delete

                            Else

                                 tmpErrorStr = tmpErrorStr & tmpName & " - Сообщение не сохранено" & VbCrLf

                            End If

                      Else

                            tmpExistStr = tmpExistStr & tmpName & " - Файл уже существует" & VbCrLf

     

                            ' УДАЛЯЕМ СООБЩЕНИЕ !!!

                            objItem.Delete

                      End If

                End If

          Next

         

          ' Получаем ссылку на коллекцию подпапок

          Set colFolders = objCurFolder.Folders

         

          ' Перебираем папки коллекции

          For Each objFolder In objCurFolder.Folders

                GetFolder(objFolder)

          Next

         

          ' Уменьшаем счетчик уровней папок

          iLevel = iLevel - 1

     

          ' Очищаем ненужные объекты

          Set colFolders = Nothing

          Set objFolder = Nothing

     

    End Sub

     

    '-----------------------------------------------

    '--- Функция получения строки заданной длины ---

    '-----------------------------------------------

    Function ConvertString(valInput, iLenght, cSymbol)

          ' Инициализация

          Dim tmpString, iLen

         

          tmpString = CStr(valInput)

          iLen = Len(tmpString)

         

          ' Если полученная строка большей длины чем требуемая - обрезаем ее

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

          If iLen>iLenght Then

                ConvertString = Left(tmpString,iLenght)

          Else

                ConvertString = String(iLenght-iLen, cSymbol) & tmpString

          End If

     

    End Function

     

    27 октября 2006 г. 11:44