Open Notes

'С 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

'С 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