Автоматическое копирование вложений из писем в папку по номеру ИНН указанному в произвольном месте

15 ноября 2015, Новости, Konstantin

Возникла очень интересная задача по обработке входящей почты, решением которой хотелось бы поделиться.

Нужно чтобы файлы из входящих писем, которые либо в теле письма, либо в теме, либо в названии файла содержат ИНН, сохранялись в папке с номером ИНН. Кроме того требуется ведения лога поступающих ИНН в отдельном файле.

Эту задачу можно разделить на следующие части:

  • Автоматическое копирование вложений из писем в папку (скрипт решающий эту задачу я уже публиковал)
  • Поиск ИНН в теме письма, теле письма или в названии вложений. Это проще всего сделать с помощью регулярных выражений.
  • Проверка ИНН по контрольному числу
  • Запись информации в лог

Кроме того, в ходе работы над скриптом я заметил ещё одну проблему. Если письмо в формате HTML и в его оформлении используются вложенные картинки, то при попытке сохранить все вложения, эти картинки сохранятся как и остальные файлы. Что не верно. Поэтому нужно ещё отличать видимые и скрытые вложения в письмах и сохранять только видимые.

Для начала нужно включить поддержку регулярных выражений в VBA. Для этого откройте редактор VBA с помощью комбинации Alt+F11. Правой кнопкой мыши нажмите на Проекте и выберите Insert > Module. Скопируйте и вставьте код макроса в модуль. Для работы макроса нужно задействовать библиотеку Microsoft VBScript Regular Expressions 5.5 в меню Tools -> References… VBA-редактора:

tools-references-regexp

Если включена библиотека VBScript Expressions 1, то отключите её сняв соответствующую галочку. Невозможно одновременно использовать v1 и v5.5.

В итоге у меня получился такой скрипт:

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
'Public Sub saveAttachtoDisk()
 
Dim objAtt As Outlook.Attachment
Dim objAttachments As Outlook.Attachment
Dim saveFolder As String
Dim logFileName As String
Dim INN As String
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim m As Match
Dim logFile, M0 As String
Dim fs, a
Dim dateOfMailItem As String
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim cid As String
Dim pa As PropertyAccessor
Dim body As String
Dim is_attach As Boolean
Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Const PR_ATTACHMENT_HIDDEN As String = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
 
saveFolder = "C:\Test\"
logFileName = "INN_Log.csv"
 
'Для тестирования скрипта на одном выделенном письме раскомментируйте
'строки ниже, удалите первую строку скрипта и раскомментируйте вторую
'Dim itm As Outlook.MailItem
'Set itm = Application.ActiveExplorer().Selection(1)
 
INN = ""
Set Reg1 = New RegExp
With Reg1
    .Pattern = "(^|\D)\d{12}($|\D)|(^|\D)\d{10}($|\D)" 'Шаблон поиска 10-ти и 12-ти значного числа
    .Global = True 'указывает, что нужно искать все совпадения
End With
'Поиск ИНН в теме письма
If Reg1.Test(itm.Subject) Then
    Set M1 = Reg1.Execute(itm.Subject)
    For Each m In M1
        M0 = m.Value
        If Not IsNumeric(Left(M0, 1)) Then M0 = Right(M0, Len(M0) - 1)
        If Not IsNumeric(Right(M0, 1)) Then M0 = Left(M0, Len(M0) - 1)
        If CheckINN(M0) Then
          INN = M0
          Exit For
        End If
    Next
End If
 
'Поиск ИНН в теле письма
If INN = "" Then
    If Reg1.Test(itm.body) Then
        Set M1 = Reg1.Execute(itm.body)
        For Each m In M1
            M0 = m.Value
            If Not IsNumeric(Left(M0, 1)) Then M0 = Right(M0, Len(M0) - 1)
            If Not IsNumeric(Right(M0, 1)) Then M0 = Left(M0, Len(M0) - 1)
            If CheckINN(M0) Then
              INN = M0
              Exit For
            End If
        Next
    End If
End If
 
 
'Поиск ИНН в названиях вложенных файлов
If INN = "" Then
  For Each objAtt In itm.Attachments
    If Reg1.Test(objAtt.FileName) Then
        Set M1 = Reg1.Execute(objAtt.FileName)
        For Each m In M1
            M0 = m.Value
            If Not IsNumeric(Left(M0, 1)) Then M0 = Right(M0, Len(M0) - 1)
            If Not IsNumeric(Right(M0, 1)) Then M0 = Left(M0, Len(M0) - 1)
            If CheckINN(M0) Then
              INN = M0
              Exit For
            End If
        Next
    End If
    Set objAtt = Nothing
  Next
End If
 
'Если ИНН где-то нашелся, то сохраняем вложение
If INN <> "" Then
  dateOfMailItem = Format(itm.ReceivedTime, "yyyymmdd")
  If Dir(saveFolder, vbDirectory) = "" Then
     MkDir saveFolder
  End If
 
  'Добавляем данные о пришедшем ИНН в лог
    Set fs = CreateObject("Scripting.FileSystemObject")
    logFile = saveFolder & logFileName
 
    If Dir(logFile, vbDirectory) = "" Then
      'Если файл с логом не обнаружен, то создаём его
      Set a = fs.CreateTextFile(logFile, True)
      a.WriteLine ("ИНН;Дата")
    Else
      'Если файл с логом обнаружен, то открываем его
      Set a = fs.OpenTextFile(logFile, ForAppending, TristateFalse)
    End If
    'Добавляем данные о полученном ИНН
    a.WriteLine (INN & ";" & itm.ReceivedTime) 'vbTab
    a.Close
 
  'Создаём папку с датой получения письма, если её ещё нет
  saveFolder = saveFolder & dateOfMailItem & "\"
  If Dir(saveFolder, vbDirectory) = "" Then
     MkDir saveFolder
  End If
  'Создаём папку с ИНН, если её ещё нет
  saveFolder = saveFolder & INN & "\"
  If Dir(saveFolder, vbDirectory) = "" Then
     MkDir saveFolder
  End If
 
  For Each objAtt In itm.Attachments
   is_attach = False
  'Проверяем не является ли файл элементом оформления письма
    Set pa = objAtt.PropertyAccessor
    cid = pa.GetProperty(PR_ATTACH_CONTENT_ID)
 
    If Len(cid) > 0 Then
      If InStr(itm.HTMLBody, cid) Then
        is_attach = False
      Else
          'Если не существует PR_ATTACHMENT_HIDDEN, то возникнет ошибка
          'Просто игнорируем эту ошибку и интерпретируем как False
          On Error Resume Next
          If Not pa.GetProperty(PR_ATTACHMENT_HIDDEN) Then
             is_attach = True
          End If
          On Error GoTo 0
          End If
    Else
      is_attach = True
    End If
  If is_attach Then
  'Проверяем наличие файла с таким же именем
    j = ""
    For i = 1 To 1000
     If Not Dir(saveFolder & j & objAtt.FileName) = "" Then
      j = "(" & i & ")_"
     Else
      Exit For
     End If
    Next i
  'Конец проверки
    objAtt.SaveAsFile saveFolder & j & objAtt.FileName 'сохраняем вложение
  End If
  Set objAtt = Nothing
  Next
End If
End Sub
 
'Функция проверки контрольных чисел в ИНН
Public Function CheckINN(sInn As String) As Boolean
    sInn = Trim$(sInn)
    Select Case Len(sInn)
        Case 10: CheckINN = CheckINN10(sInn)
        Case 12: CheckINN = CheckINN12(sInn)
    End Select
End Function
 
'Проверка 10-ти значного ИНН
Private Function CheckINN10(sInn As String) As Boolean
    Dim i As Integer, s As String, j As Integer, v As Variant
 
    v = Array(2, 4, 10, 3, 5, 9, 4, 6, 8, 0)
    For i = 1 To 10
        s = Mid$(sInn, i, 1)
        If Not IsNumeric(s) Then Exit Function
        j = j + CInt(v(i - 1)) * CInt(s)
    Next i
    j = j Mod 11
    If j > 9 Then j = j Mod 10
    CheckINN10 = (j = CInt(s))
End Function
 
'Проверка 12-ти значного ИНН
Private Function CheckINN12(sInn As String) As Boolean
    Dim i As Integer, s As String, j As Integer, v As Variant
 
    v = Array(3, 7, 2, 4, 10, 3, 5, 9, 4, 6, 8, 0)
 
    For i = 1 To 12
        s = Mid$(sInn, i, 1)
        If Not IsNumeric(s) Then Exit Function
        j = j + CInt(v(i - 1)) * CInt(s)
        If i = 11 Then s0 = s
    Next i
    j = j Mod 11
    If j > 9 Then j = j Mod 10
    If j <> CInt(s) Then Exit Function
 
    j = 0
    For i = 1 To 11
        j = j + CInt(v(i)) * CInt(Mid$(sInn, i, 1))
    Next i
    j = j Mod 11
    If j > 9 Then j = j Mod 10
 
    CheckINN12 = (j = CInt(s0))
End Function

Скрипт ищет первый правильный ИНН. Сначала в теме письма, затем в теле письма, затем в названиях вложенных файлов. Проверяются контрольные числа в ИНН. Если число не прошло проверку, то поиск продолжается. Если ИНН нигде не найден, то дальше ничего не происходит. А если найден, то вложения из письма сохраняются в папку C:/Test/<дата поступления>/<номер_ИНН>, причём дата поступления в формате ГГГГММДД.

Кроме того информация о пришедших ИНН сохраняется в файле-логе INN_Log.csv в папке C:/Test/. Туда записывается ИНН и дата поступления письма. Если файла нет в указанной папке, то он создаётся.

Важно Лучше не открывать файл лога, когда открыт Outlook, чтобы избежать случаев, когда вы откроете файл, а Outlook попытается записать туда информацию о новом поступившем ИНН и не сможет этого сделать.

Создание правила обработки входящих писем скриптом

  1. В Outlook откройте окно VBA. Можно воспользоваться сочетанием Alt + F11.
  2. Вставьте код, прописанный выше, в раздел Modules. Слева найдите Modules. Если там нет раздела нет пункта Module, то создайте такой правым щелчком мыши по Modules. Или нажмите правой кнопкой по Modules, Insert -> Module.
  3. Скопируйте код в главное окно.
  4. Закройте VBA IDE.
  5. Создайте правило, вызывающее скрипт.
  6. В первом окне мастера создания нового правила выберите проверку входящих писем.
  7. В следующем окне выберите правила отбора писем.
  8. В третьем окне выберите «выполнить скрипт» (или «запустить скрипт»). Когда нажмете на подчеркнутое слов «скрипт», должен быть виден код, который был вставлен в консоль VBA.
  9. Нажмите «Завершить» и проверьте работу правила.

Источники информации

Order_macros

Теги: • • • • • • •
 
Распечатать Распечатать

2 комментария в “Автоматическое копирование вложений из писем в папку по номеру ИНН указанному в произвольном месте”

  1. Владимир:
    9 декабря 2015 в 12:07

    Добрый день! Скрипт очень помог, особенно часть кода о поиске ИНН в произвольном «месте» письма. Спасибо большое за статью.

    Ответить
  2. RMAU:
    25 апреля 2016 в 3:12

    Для этих целей в Outlook можно создать макрос и настроить его запуск в правилах для электронной почты. В правилах же можно указать при получении каких именно писем, от какого отправителя нужно запускать макрос, который сохраняет вложения на диск.

    Ответить

Комментировать

 


На Верх