Проблема при отправке почты из Excel через Outlook (добавление нескольких файлов в текст письма Outlook)

Пользователь

Сообщений: 20 Регистрация: 11.07.2021

14.11.2021 00:23:23

Доброго времени суток

Сделал таблицу для отправки сообщений различным адресатам. При выборе различной тематики сообщения подтягивается:
1) в ячейку G3 - адресат
2) в ячейку G4 - тема сообщения
3) в ячейку G5 - текст сообщения
4) в ячейку G6 - пустое значение, ссылка на вложение или ссылки на вложения

К примеру, в одном из вариантов выбора G6 имеет вот какое значение:

Код

"\\fuib.com\kho\DOCUMENTYOOKUTU\Кулиничев\! открытие счетов\закрытие счетов\заявление о закрытии счёта ЮЛ.doc"; "\\fuib.com\kho\DOCUMENTYOOKUTU\Кулиничев\! открытие счетов\тарифы\Раздел 1. Расчетно-кассовое обслуживание.doc"; "\\fuib.com\kho\DOCUMENTYOOKUTU\Кулиничев\! открытие счетов\реквизиты на оплату\!Реквизиты - закрытие счетов (КНО).doc"

Нашёл на просторах интернета скрипт для отправки сообщения из Excel адресатy через Outlook, но скрипт добавляет в сообщение только первый файл из тех, которые указаны в G6 (скрин прилагаю).

Помогите, пожалуйста, дописать скрипт так чтобы добавлялись все файлы, пути которых указаны в ячейке G6 (они размещены на сетевых дисках в различных подпапках. Решения проблемы на форуме и сторонних сайтах, к сожалению, я не нашёл. Если это, по каким-то причинам, невозможно, к сожалению, не силён в VBA, то, может, предложите какие-то варианты. Буду дальше копаться по сайтам.

Заранее спасибо.

Код

Option Explicit
 
Sub Send_mail_shablony_documentov()  'Источник https://www.excel-vba.ru/chto-umeet-excel/kak-otpravit-pismo-iz-excel/

' макрос для отправки сообщений

    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
 
    Application.ScreenUpdating = False
    On Error Resume Next
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    'раскомментировать строку, если в Outlook несколько учетных записей и нужно подключиться к конкретной(только если Outlook закрыть)
    '   [параметры]: Session.Logon "имя профиля","пароль",[показывать окно выбора профиля], [запускать в новой сессии]
    'objOutlookApp.Session.Logon "profile","1234",False, True
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = Range("G3").Value             'Кому(можно заменить значением из ячейки - sTo = "AddressTo@mail.ru")
    sSubject = Range("G4").Value        'Тема письма(можно заменить значением из ячейки - sSubject = "Автоотправка")
    sBody = Range("G5").Value           'Текст письма(можно заменить значением из ячейки - sBody = "Привет от Excel-VBA")
    sAttachment = Range("G6").Value     'Вложение(полный путь к файлу. Можно заменить значением из ячейки или путь - sAttachment = "C:\Temp\Книга1.xls")
    
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        '.CC = Range("B3").Value 'адрес для копии
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.) / .Body = sBody - обычный текст сообщения
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            If Dir(sAttachment, 16) <> "" Then
                .Attachments.Add sAttachment 'просто вложение
                'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
            End If
        End If
        .display 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра; .Send - сразу отправка
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Прикрепленные файлы

Книга1.xlsm (18.69 КБ)
Безымянный.jpg (85.86 КБ)

New

Пользователь

Сообщений: 4915 Регистрация: 06.01.2013

14.11.2021 00:37:15

я не тестировал, но попробуйте так. Если будут ошибки пишите

Код

Sub Send_mail_shablony_documentov()
    ' макрос для отправки сообщений
    
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
    Dim arrAttachments, i As Long, vOneAttachement As Variant
    
    Application.ScreenUpdating = False
    On Error Resume Next
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    
    'раскомментировать строку, если в Outlook несколько учетных записей и нужно подключиться к конкретной(только если Outlook закрыть)
    '   [параметры]: Session.Logon "имя профиля","пароль",[показывать окно выбора профиля], [запускать в новой сессии]
    'objOutlookApp.Session.Logon "profile","1234",False, True
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = Range("G3").Value             'Кому(можно заменить значением из ячейки - sTo = "AddressTo@mail.ru")
    sSubject = Range("G4").Value        'Тема письма(можно заменить значением из ячейки - sSubject = "Автоотправка")
    sBody = Range("G5").Value           'Текст письма(можно заменить значением из ячейки - sBody = "Привет от Excel-VBA")
    
    'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
    sAttachment = Range("G6").Value     'Вложение(полный путь к файлу. Можно заменить значением из ячейки или путь - sAttachment = "C:\Temp\Книга1.xls")
       
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        '.CC = Range("B3").Value 'адрес для копии
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.) / .Body = sBody - обычный текст сообщения
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If sAttachment <> "" Then
            arrAttachments = Split(sAttachment, ";")
            For Each vOneAttachement In arrAttachments
                vOneAttachement = Application.Trim(Replace(vOneAttachement, """", "", 1))
                If Dir(vOneAttachement, 16) <> "" Then
                    .Attachments.Add vOneAttachement 'вложение
                End If
            Next vOneAttachement
        End If
        .display 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра; .Send - сразу отправка
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Изменено: New - 14.11.2021 13:25:30

Олег Кулиничев Пользователь Сообщений: 20 Регистрация: 11.07.2021	#3 14.11.2021 02:50:34 Пока работает без ошибок! ОГРОМНОЕ человеческое спасибо! Изменено: Олег Кулиничев - 14.11.2021 03:13:05