Макрос автоматической распечатки всех входящих писем 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 Комментарии
Комментировать

На Верх