Мне поступил заказ на разработку макроса для 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
Чуть позже заказчик попросил добавить вывод сообщения о готовящейся распечатке, чтобы случайно не распечатать спам. Поэтому в коде добавлена часть с MsgBox. Если вам этого не требуется, то удалить часть с MsgBox и End If в конце. Кроме того я добавил в код проверку изображений на принадлежность к HTML-оформлению письма.
При использовании кода нужно изменить все пути (путь к mspaint.exe (в двух местах), к winrar.exe, к AcroRd32.exe (в двух местах) и к папке для временного сохранения файлов, подготовленных к печати. Сам код следует добавить в раздел ThisOutlookSession.
После этого создайте правило для всех входящих писем.
Выполнение скрипта вывода на печать
Источники информации
- Macro to Print Outlook email attachments as they arrive
- Решение проблемы с печатью PDF — Solved: How to auto print .PDF files
- Как программно удалить из папки все файлы?
- Один из способов печати изображений через UserForms — Как распечатать jpeg файл из VBA Excel
- Способ печати изображений с помощью Paint — Print .bmp file in vb6
- Ещё один способ печати изображений — Printing an image (tiff) file