Макрос автоматической распечатки всех входящих писем Outlook и их вложений

13 сентября 2016, VBA, Konstantin

Мне поступил заказ на разработку макроса для Outlook, который будет сразу после поступления письма, без какого бы то ни было участия, распечатывать само письмо, его вложения (файлы *.doc, *.docx, *.xls, *.xlsx а также *.jpg и *.pdf). А если в письмо вложен архив, то макрос должен его распаковать и распечатать находящиеся внутри документы.
Задача показалась мне интересной и я взялся за неё.
Поискав в сети, я нашел готовое решение, которое позволяло частично выполнить задачу.
Документы печатать было уже можно (должен быть установлен MS Office). Однако оставалось решить ещё несколько проблем:

  • При попытке напечатать таким образом изображения появляется окно вывода на печать, где требуется ещё нажать кнопку. Т.е. уже не выполняется условие «без участия пользователя».
  • Для печати PDF не получится воспользоваться средствами MS Office.
  • Нужно добавить распаковку *.rar и *.zip архивов

Для решения первой проблемы решено было использовать Paint, который установлен практически на любом компьютере с Windows. Вторая проблема решается установкой на компьютер Adob Reader и печатью силами данной программы. А третья проблема легко будет устранена если на компьютере стоит WinRAR.
В итоге получился следующий код:

'С 64-битным Outlook нужно использовать Declare PtrSafe Function
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
    ByVal lpFile As String, ByVal lpParameters As String, _
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
 
Private WithEvents Items As Outlook.Items
 
Private Sub Application_Startup()
    Dim olNameSpace As Outlook.NameSpace
    Dim Folder As Outlook.MAPIFolder
 
    Set olNameSpace = Application.GetNamespace("MAPI")
    Set Folder = olNameSpace.GetDefaultFolder(olFolderInbox)
    Set Items = Folder.Items
End Sub
 
Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
        PrintAttachments Item
    End If
End Sub
 
'Печать вложений из письма
Private Sub PrintAttachments(olItem As Outlook.MailItem)
    On Error Resume Next
    Dim colAtts As Outlook.Attachments
    Dim olAtt As Outlook.Attachment
    Dim sFile As String
    Dim sDirectory As String
    Dim sFileType As String
    Dim pa As PropertyAccessor
    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"
    Dim str1() As String
    Dim str2() As String
 
    sDirectory = "C:\Test\"
 
    Set colAtts = olItem.Attachments
 
    If colAtts.Count Then
        For Each olAtt In colAtts
 
           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
 
        'определение расширения файла
        str1 = Split(olAtt.FileName, ".")
        sFileType = "." & LCase(str1(UBound(str1)))
 
        Select Case sFileType
            Case ".xls", ".xlsx", ".doc", ".docx"
            sFile = sDirectory & "FileForPrint_" & olAtt.Index & sFileType
            olAtt.SaveAsFile sFile
            ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
            Case ".pdf"
            sFile = sDirectory & "FileForPrint_" & olAtt.Index & sFileType
            olAtt.SaveAsFile sFile
            'Прописать путь к AcroRd32.exe
            Shell "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe /p /h " & sFile
            Case ".jpg", ".png"
            sFile = sDirectory & "FileForPrint_" & olAtt.Index & sFileType
            olAtt.SaveAsFile sFile
            'Прописать путь к mspaint.exe
            Shell "C:\WINDOWS\system32\mspaint.exe " & sFile & " /p"
            Case ".zip", ".rar"
            sFile = sDirectory & "FileForPrint_" & olAtt.Index & sFileType
            sDir = sDirectory & "FileForPrint_" & olAtt.Index
             If Dir(sDir, vbDirectory) <> "" Then
                Kill sDir & "\*.*"
                RmDir sDir
             End If
            olAtt.SaveAsFile sFile
            'Прописать путь к winrar.exe
            Shell "C:\Program Files\WinRAR\winrar.exe e " & sFile & " " & sDir & "\"
            strFileName = Dir(sDir & "\" & "*.*")
 
            Do While strFileName <> "" 'До тех пор пока файлы "не закончатся"
                'MsgBox strFileName
                str2 = Split(strFileName, ".")
                sFileType2 = "." & LCase(str2(UBound(str2)))
                Select Case sFileType2
                    Case ".xls", ".xlsx", ".doc", ".docx"
                    ShellExecute 0, "print", sDir & "\" & strFileName, vbNullString, vbNullString, 0
                    Case ".pdf"
                    'Прописать путь к AcroRd32.exe
                    Shell "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe /p /h " & sDir & "\" & strFileName
                    Case ".jpg", ".png"
                    sFile = sDirectory & "FileForPrint_" & olAtt.Index & sFileType
                    olAtt.SaveAsFile sFile
                   'Прописать путь к mspaint.exe
                    Shell "C:\WINDOWS\system32\mspaint.exe " & sDir & "\" & strFileName & " /p"
                End Select
                strFileName = Dir 'Следующий файл
            Loop
            End Select
        Next
    End If
End Sub
 
'Процедура печать текста письма
Private Sub PrintMessage(sDir)
    On Error Resume Next
    ShellExecute 0, "Print", sDir, vbNullString, "", 1
End Sub
 
 
Public Sub PrintMessageAndAttach(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
'Нужно создать папку, куда временно будут сохраняться письма и их вложения перед печатью (прописывается без обратного слеша в конце)
saveFolder = "C:\\Test"
 If Dir(saveFolder, vbDirectory) = "" Then
     MkDir saveFolder
 End If
 
'Сообщение, которое всплывает после получения письма
'Для наглядности оно отображает Тему письма, email отправителя, и количество вложений
If MsgBox("Вы хотите распечатать входящее письмо и все его вложения?" & Chr(10) & _
          "Тема: " & itm.Subject & Chr(10) & _
          "Отправитель: " & itm.SenderEmailAddress & Chr(10) & _
          "Вложения: " & itm.Attachments.Count, vbYesNo, "Печать письма и вложений") = vbYes Then
 
'Сохранение письма и его печать
itm.SaveAs (saveFolder & "\Message_For_Print.msg")
PrintMessage saveFolder & "\Message_For_Print.msg"
 
'Печать вложений
PrintAttachments itm
 
End If
End Sub

Продолжить чтение »

Теги: • • •
 
2 Комментарии
Комментировать

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

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

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

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

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

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

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

Продолжить чтение »

Теги: • • • • • • •
 
2 Комментарии
Комментировать

Использование регулярных выражений в VBA для извлечения текста из сообщений Outlook

10 ноября 2015, VBA, Konstantin

Есть несколько способов поиска определённого текста в теле письма с помощью VBA. Можно воспользоваться функциями InStr, Len, Left или Right, чтобы найти и извлечь текст, а можно воспользоваться регулярными выражениями. Именно о применении регулярных выражений в коде VBA пойдёт речь в данной статье.

Например, требуется извлечь код отслеживания посылки UPS, отправленной с Amazon.com. Такой код имеет формат как на скриншете ниже:

tracking-code-sample-regexp

Нужно находить в тексте слова «Carrier Tracking ID», затем, возможно, пробел и двоеточие.

.Pattern = "(Carrier Tracking ID\s*[:]+\s*(\w*)\s*)"

Такое выражение извлечёт из текста из примера цифро-буквенный код 1Z2V37F8YW51233715.

Продолжить чтение »

Теги: • • • • • •
 
1 Комментарии
Комментировать

Открыть Outlook msg-сообщения из папки с помощью VBA и сохранить вложение

8 ноября 2015, VBA, Konstantin

Возникла следующая задача:

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

Это можно сделать, используя Windows Scripting Host и метод Application.CreateItemFromTemplate для открытия сообщений. После открытия, можно сохранить вложения или делать все, что нужно сделать с сообщением.

Продолжить чтение »

Теги: • • • • • •
 
0 Комментарии
Комментировать

На Верх