Public Sub SendEmailWtAttachment(sToEMails$, sSybject$, Optional sBody$, _
Optional sAttachmentPath$, Optional sSaveCopyToFolder$)
'es 16.02.2005 - LE 26.12.2022 v005
'---------------------------------------------------------------------------------------------------
'процедура отправки сообщения посредством MS OutLook с вложением (опционально) и сохранением файла копии (опционально)
'procedure for sending a message via MS OutLook With attachment (optional) and saving copy file (optional)
'---------------------------------------------------------------------------------------------------
'Аргументы:
' sToEMails 'Адрес, или адреса через точку с запятой - Address, or semicolon addresses
' sSybject 'Тема - Subject
' sBody 'Текст (тело сообщения) - Text (message body)
' sAttachmentPath 'Полный путь к вложению (опционально) - Full path to attachment (optional)
' sSaveCopyToFolder 'Путь к к папке куда сохранить копию (опционально)
'Path to the folder where to save the copy (optional)
'---------------------------------------------------------------------------------------------------
'Usage:
' SendEmailWtAttachment "name@domen.ru", "Text of Subject", "message ...", "C:\Temp\filename.zip"
'---------------------------------------------------------------------------------------------------
Dim olObjApp As Object 'MS Outlook application
Dim olObjItem As Object 'MS Outlook item (message)
Dim s$
On Error GoTo SendEmailWtAttachmentErr
Set olObjApp = CreateObject("Outlook.Application")
Set olObjItem = olObjApp.CreateItem(0)
'* cм https://msdn.microsoft.com/ru-ru/library/office/ff869291.aspx
'Creating message
With olObjItem
.To = sToEMails
.Subject = sSybject
.Body = sBody
If sAttachmentPath <> "" Then
If Dir(sAttachmentPath) <> "" Then
.Attachments.Add sAttachmentPath
End If
End If
'Saving a message (still in "Drafts")
.Save 'Сохранение сообщения (пока в Черновиках)
'Отправка - Но это не фактическая отправка, а только помещение в папку "Исходящие" (OutBox)
'Sending - But this is not the actual sending, but only putting it in the Outbox folder (OutBox)
.Send
'... а далеше OutLook будет действовать по своим настройкам ("Мгновенная отправка")
''...and then OutLook will act on its settings ('Instant Send')
'Экспортирование - если указан аргумент - Export - if the argument is specified
If sSaveCopyToFolder <> "" Then
s = sSaveCopyToFolder
If Right(s, 1) <> "\" Then s = s & "\"
s = s & sSybject & ".msg" 'Путь сохранения копии - Save copy path
Debug.Print s
.SaveAs s, 3
End If
End With
Set olObjItem = Nothing
Set olObjApp = Nothing
Exit Sub
SendEmailWtAttachmentErr:
If Err.Number = "287" Then
MsgBox "You declined to create a message!", vbInformation, "Сообщение не создано"
Else
MsgBox Err.Description, vbCritical, "Error!"
End If
End Sub
