TopPicLogo TopPicText

MS OutLook - Создание и отправка сообщения с вложением (опционально) и экспортом в файл копии (опционально)

Полезная инфа:
MailItem Object (Outlook): https://msdn.microsoft.com/ru-ru/library/office/ff861332.aspx
OlItemType Enumeration (Outlook): https://msdn.microsoft.com/ru-ru/library/office/ff869291.aspx.  

Пример применения:

    SendEmailWtAttachment "name@domen.ru", "Тема", "Текст Сообщения", "C:\Temp\filename.zip"
    SendEmailWtAttachment "8768972867077@gmail.com", "test01", "Привет!", , "d:\temp"


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

Public Sub SendEmailWtAttachment(sToEMails$, sSybject$, Optional sBody$, _
        Optional sAttachmentPath$, Optional sSaveCopyToFolder$)
'es 16.02.05 - 06.05.2017
'----------------------------------------------------------------------------
'MS Access VBA - процедура отправки сообщения посредством MS OutLook
'с вложением (опционально) и сохранением файла копии (опционально)
'es 16.02.05 - 06.05.2017
'----------------------------------------------------------------------------
'Аргументы:
'   sToEMails          'Адрес, или адреса через точку с запятой
'   sSybject           'Тема
'   sBody              'Текст (тело сообщения)
'   sAttachmentPath    'Полный путь к вложению (опционально)
'   sSaveCopyToFolder  'Путь к к папке куда сохранить копию (опционально)
'----------------------------------------------------------------------------
'Полезная инфа:
'   * MailItem Object (Outlook)
'   https://msdn.microsoft.com/ru-ru/library/office/ff861332.aspx
'   * OlItemType Enumeration (Outlook)
'   https://msdn.microsoft.com/ru-ru/library/office/ff869291.aspx
'----------------------------------------------------------------------------

Dim olObjApp As Object      'Ссылка на MS Outlook
Dim olObjItem As Object     'Ссылка на сообщение
Dim s$

On Error GoTo SendEmailWtAttachmentErr

    Set olObjApp = CreateObject("Outlook.Application")
    Set olObjItem = olObjApp.CreateItem(0) '0 = письмишко значит ...
    '* cм https://msdn.microsoft.com/ru-ru/library/office/ff869291.aspx
    
'Создание сообщения
    With olObjItem
        .To = sToEMails          'кому
        .Subject = sSybject      'тема
        .Body = sBody            'текст

        '*  Если нужно несколько вложений - можно поиграть с коллекцией ниже
        '*  и именить аргумент процедуры на массив например, но не будем усложнять
        If sAttachmentPath <> "" Then
            If Dir(sAttachmentPath) <> "" Then
                .Attachments.Add sAttachmentPath
            End If
        End If
        
        '.Display 'Отображение сообщения (если нужно)
        .Save    'Сохранение сообщения (пока в Черновиках)
        
        'Но это не фактическая отправка, а только помещение в папку "Исходящие" (OutBox)
        .Send
        '... а далеше OutLook будет действовать по своим настройкам ("Мгновенная отправка")

'Экспортирование - если указан аргумент
        If sSaveCopyToFolder <> "" Then
            s = sSaveCopyToFolder
            If Right(s, 1) <> "\" Then s = s & "\"
            
            ' а можно м с этим: .EntryID = строчка в 50 (!!!) симсолов
            s = s & sSybject & ".msg" 'Путь сохранения копии
            Debug.Print s
            .SaveAs s, 3 'Схраняем ...
            '... и тут 3 = olObjSaveAsMsg (MS OutLook Format *.msg)
        End If
    

    End With
    
    Set olObjItem = Nothing
    Set olObjApp = Nothing
    Exit Sub
    
SendEmailWtAttachmentErr:
   If Err.Number = "287" Then 'На всякий случай
      MsgBox "Вы отказались от создания сообщения!", vbInformation, "Сообщение не создано"
   Else
      MsgBox Err.Description, vbCritical, "Error!"
   End If
End Sub

Назад ToTop
L.E. 06.05.2017
Рейтинг@Mail.ru