Страницы: 1
RSS
Массовая рассылка писем по адресам при помощи Outlook
 
Добрый день, подскажите, пытаюсь создать несколько сообщений в 1 макросе (необходимо 10 сообщений - 1 макросом), но ничего не выходит, ниже код, пытаюсь изначально сделать хотя бы 2 сообщения в связке, пожалуйста подскажите

Код
Sub Send_Mail()
    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
    objOutlookApp.Session.Logon
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = Range("B1").Value  'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sCC = Range("B2").Value 'Копия(можно заменить значением из ячейки - sBCC = Range("A1").Value)
    sBCC = Range("B3").Value 'Скрытая копия(можно заменить значением из ячейки - sBCC = Range("A1").Value)
    sSubject = Range("B5").Value  'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = Range("B7").Value  'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
           
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = sCC 'адрес для копии
        .BCC = sBCC 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If Dir(sAttachment, 16) <> "" Then
            .Attachments.Add sAttachment 'просто вложение
            'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
        End If
        .Display 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
  
Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = Range("B1").Value  'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sCC = Range("B2").Value 'Копия(можно заменить значением из ячейки - sBCC = Range("A1").Value)
    sBCC = Range("B3").Value 'Скрытая копия(можно заменить значением из ячейки - sBCC = Range("A1").Value)
    sSubject = Range("B5").Value  'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = Range("B7").Value  'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
           
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = sCC 'адрес для копии
        .BCC = sBCC 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If Dir(sAttachment, 16) <> "" Then
            .Attachments.Add sAttachment 'просто вложение
            'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
        End If
        .Display 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
  
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub
 
в этом макросе 3 сообщения
Код
Sub MSGS
  MsgBox "Сообщение 1"
  MsgBox "Сообщение 2"
  MsgBox "Сообщение 3"
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Сейчас всё "вернул" на место и вообще, даже 1 сообщение не отправляется  8-0  Пожалуйста подскажите, не напортачил ли я в коде
Код
Sub Send_Mail()
    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
    objOutlookApp.Session.Logon
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = Range("B1").Value  'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sCC = Range("B2").Value 'Копия(можно заменить значением из ячейки - sCC = Range("A1").Value)
    sBCC = Range("B3").Value 'Скрытая копия(можно заменить значением из ячейки - sBCC = Range("A1").Value)
    sSubject = Range("B5").Value  'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sAttachment = Range("B6").Value  'Вложения (можно заменить значением из ячейки - sAttachement = Range("A2").Value)
    sBody = Range("B7").Value  'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
            
           
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = sCC 'адрес для копии
        .BCC = sBCC 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
        'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
        If Dir(sAttachment, 16) <> "" Then
            .Attachments.Add sAttachment 'просто вложение
            'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
        End If
        .Display 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
  
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Изменено: Andrey Melnikov - 10.08.2020 14:30:41
 
Andrey Melnikov, код следует оформлять соответствующим тегом. Ищите такую кнопку (см скрин) и исправьте своё сообщение.
 
Подскажите по поводу ошибки, пожалуйста  
 
а какая ошибка, что пишет?  
 
Так вроде и раньше в коде не наблюдается
Код
.Send

только всюду .Display...
P.S. Вот тут вроде как должно быть всё исчерпывающе. Но я не нашёл как "создать несколько сообщений в 1 макросе" :( В смысле отправить одно письмо сразу по нескольким адресам, обычно это делали давая их как массив, но т.к. оутлука не имею, проверить не могу...
А как в одном макросе отправить хоть 100500 писем - там есть :)
Изменено: Hugo - 12.08.2020 16:54:47
 
Цитата
а какая ошибка, что пишет?  
Дело в том, что ничего "не пишет", excel как-будто обновляется и всё...никаких действий  
Изменено: Andrey Melnikov - 14.08.2020 11:44:33
 
Andrey Melnikov, полюбуйтесь на свой замечательный пост. Вернитесь и приведите его в порядок.
 
Если бы вы приложили файл-пример и более подробно написали чего хотите - было бы проще вам помочь.
 
В общем-то, там откуда Вы взяли этот код, есть пример массовой рассылки:
Массовая рассылка писем по адресам при помощи Outlook
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Всё испробовал, ничего не помогает, файл с моим "творчеством" во вложении, если кто может, помогите или направьте в нужном русле
При нажатии "Выполнить" макрос - ничего не происходит, ни ошибки нет - ничего, просто как-будто обновляется Excel на секудну...
 
Закомментируйте On Error Resume Next и посмотрите, на каккой строке ошибка.
 
И название темы тоже думаю нужно изменить. Например на это:
Цитата
Дмитрий(The_Prist) Щербаков написал:
Массовая рассылка писем по адресам при помощи Outlook
 
Цитата
В общем-то, там откуда Вы взяли этот код, есть пример массовой рассылки
Скачал пример с этого сайта  Tips_Macro_SendMail_Mass.xls , ничего не меняю в коде - нажимаю выполнить и в ответ никакой реакции   8-0  8-0
В параметрах безопасности - включены все макросы

Цитата
Закомментируйте On Error Resume Next
"Закомментировал" - ничего не происходит
код удален
 
Цитата
Andrey Melnikov написал: "Закомментировал"
Зачем повторно код показывать? Тем более, что указанная строка  не отключена...
 
Цитата
Andrey Melnikov написал:
ничего не меняю в коде - нажимаю выполнить и в ответ никакой реакции
вообще ничего не меняли? адреса хоть какие в ячейки записывали? Или оставили все как есть?
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Всё оставил как есть, единственное .display написал, должно же что-либо происходить, но вообще ничего не происходит  
 
Цитата
vikttur написал: ...указанная строка  не отключена...
Спасибо, "Закомментируйте" = отключить, сразу после этого начали "появляться" ошибки из-за которых не создавался макрос.
Макрос не создавался, потому что в ячейке b6 не была указана "дорога" к файлу-вложению (sAttachment = Range("B6").Value)
Форум действительно классный. Всем огромное спасибо.
Осталось только разобраться, как, всё-таки, используя 1 клавишу - отправлять разного рода сообщения на одни и те же адреса  8-0  
 
Цитата
Andrey Melnikov написал:
отправлять разного рода сообщения
а что это значит? В том же файле указываете одни и те же адреса во всех строчках, но тексты сообщений для них указываете разные и все. Разве нет?
Цитата
Andrey Melnikov написал:
в ячейке b6 не была указана "дорога" к файлу-вложению (sAttachment = Range("B6").Value)
либо я чего-то не понимаю, либо мы сейчас говорим про код массовой рассылки, а приводите Вы нам текст отсылки одного письма, в котором есть проверка:
Код
If Dir(sAttachment, 16) <> "" Then
её можно также и в массовую рассылку добавить и все:
Код
If Dir(Cells(lr, 4).Value, 16) <> "" Then
.Attachments.Add Cells(lr, 4).Value
End If
Изменено: Дмитрий(The_Prist) Щербаков - 17.08.2020 11:10:49
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Цитата
Дмитрий(The_Prist) Щербаков написал:
а что это значит? В том же файле указываете одни и те же адреса во всех строчках, но тексты сообщений для них указываете разные и все. Разве нет?

Дмитрий, спасибо, я пытаюсь отправить n-количество сообщений, каждое сообщение - уникальное на одни и те же адреса, но у меня не получается
ниже мой рабочий код, как его можно дополнить, чтобы создавалось не 1 сообщение а 10, изменяя значения sTO, sCC и т.д
Код
Sub sendmail()

Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
      
    Application.ScreenUpdating = False
    
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    objOutlookApp.Session.Logon
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
  
    sTo = Range("B1").Value  'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sCC = Range("B2").Value  'Копия(можно заменить значением из ячейки - sCC = Range("A1").Value)
    sBCC = Range("B3").Value 'Скрытая копия(можно заменить значением из ячейки - sBCC = Range("A1").Value)
    sSubject = Range("B5").Value  'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = Range("B7").Value  'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
             
            
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = sCC 'адрес для копии
        .BCC = sBCC 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.
        .Display 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
   
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Изменено: Andrey Melnikov - 19.08.2020 12:50:32
 
Попытался откорректировать код, но на значении  "sTo = Range("С1").Value  'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value) - вылетает ошибка, что код написан - неверно
Код
Sub sendmail()

Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
      
    Application.ScreenUpdating = False
    
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    objOutlookApp.Session.Logon
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
  
    sTo = Range("B1").Value  'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sCC = Range("B2").Value  'Копия(можно заменить значением из ячейки - sCC = Range("A1").Value)
    sBCC = Range("B3").Value 'Скрытая копия(можно заменить значением из ячейки - sBCC = Range("A1").Value)
    sSubject = Range("B5").Value  'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = Range("B7").Value  'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
             
            
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = sCC 'адрес для копии
        .BCC = sBCC 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.
        .Display 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
    
    Set objMail = objOutlookApp.CreateItem(1)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
  
    sTo = Range("С1").Value  'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sCC = Range("С2").Value  'Копия(можно заменить значением из ячейки - sCC = Range("A1").Value)
    sBCC = Range("С3").Value 'Скрытая копия(можно заменить значением из ячейки - sBCC = Range("A1").Value)
    sSubject = Range("С5").Value  'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = Range("С7").Value  'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
             
            
    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .CC = sCC 'адрес для копии
        .BCC = sBCC 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.
        .Display 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
   
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub
 
Код
 lLastR = Cells(Rows.Count, 1).End(xlUp).Row 'определяем последнюю заполненную ячейку в столбце А
    'цикл от второй строки(начало данных с адресами) до последней ячейки таблицы
    For lr = 2 To lLastR
        Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
        'создаем сообщение
        With objMail
            .to = Cells(lr, 1).Value 'адрес получателя
            .CC = Cells(lr, 1).Value 'копия
            .BCC = Cells(lr, 1).Value 'адрес для скрытой копии
            .Subject = Cells(lr, 2).Value 'тема сообщения
            .Body = Cells(lr, 3).Value 'текст сообщения
            .Attachments.Add Cells(lr, 4).Value
            .Display 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
        End With
Проблема потихоньку решается, кто-нибудь, пожалуйста объясните значение этих строчек
Код
 lLastR = Cells(Rows.Count, 1).End(xlUp).Row 'определяем последнюю заполненную ячейку в столбце А
    'цикл от второй строки(начало данных с адресами) до последней ячейки таблицы
    For lr = 2 To lLastR
Я так понял, это работает по столбцам (данные вставляются берутся из столбцов, мне надо чтобы данные брались из строчек) H e l p  
 
Всем спасибо!
Вот рабочий код, к которому я пришёл за 48 часов, благодаря каждому, кто отписывался в теме
Код
Sub sendmail()

Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
      
    Application.ScreenUpdating = False
    
    'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    objOutlookApp.Session.Logon
    
    lLastR = Cells(Rows.Count, 1).End(xlUp).Row 'определяем последнюю заполненную ячейку в столбце А
    'цикл от второй строки(начало данных с адресами) до последней ячейки таблицы
    For lr = 2 To lLastR
        Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
        'создаем сообщение
        With objMail
            .To = Cells(lr, 1).Value 'адрес получателя
            .CC = Cells(lr, 2).Value 'копия
            .BCC = Cells(lr, 3).Value 'адрес для скрытой копии
            .Subject = Cells(lr, 4).Value 'тема сообщения
            .Body = Cells(lr, 6).Value 'текст сообщения
            .Display 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра
        End With
    Next lr
          
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

К сожалению с вложениями пока не разобрался, но благодаря коду выше - вы сможете отправить что вам нужно, в неограниченном количестве, куда угодно
Страницы: 1
Наверх