Доброго дня всем! Нашел замечательный код для рассылки любого количества писем, что очень помогло сэкономить кучу времени. Вот он:
Вопрос знатокам! Рассылать приходится около трехсот писем, и, естественно,это занимает время. Может кто поможет дописать код так,что бы по окончании рассылки выводилось сообщение о завершении операции, или еще лучше что то типа: "Операция успешно завершена. Отправлено столько то писем". Всем буду благодарен!
Код |
---|
Sub Send_Mail_Mass() Dim objOutlookApp As Object, objMail As Object Dim sTo As String, sSubject As String, sBody As String, sAttachment As String Dim lr As Long, lLastR As Long 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 'произошла ошибка создания объекта - выход If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub 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 'адрес получателя .Subject = Cells(lr, 2).Value 'тема сообщения .Body = Cells(lr, 3).Value 'текст сообщения .Attachments.Add Cells(lr, 4).Value .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра End With Next lr Set objOutlookApp = Nothing: Set objMail = Nothing Application.ScreenUpdating = True End Sub |