mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Отправка почты макросом VBA без использования почтовых программ

ВНИМАНИЕ! Данный код гарантированно работает ТОЛЬКО в ОС WindowsXP.
В остальных версиях Windows код не проверял.
В Windows7 данный макрос работать не будет ввиду отсутствия библиотеки CDO for Windows 2000.
(потребуется ручная установка недостающей библиотеки)

Пример отправки почты макросом Excel:

Sub Main()    ' Пример использования функции Send_Mail
    txt = "Это письмо сформировано макросом" & vbNewLine & _
          "без использования внешних программ и подключения дополнительных библиотек"
    If Send_Mail("ivan_ivanov@mail.ru", "vasya_pupkin@mail.ru", "проверка отправки почты", txt) Then
        MsgBox "Письмо успешно отправлено", vbInformation
    Else
        MsgBox "Не удалось отправить письмо", vbExclamation
    End If
End Sub

Ознакомьтесь также со способом отправки почты из Excel
с использованием почтовой программы TheBAT!

Для рассылки писем со вложениями, и настраиваемым текстом и темой письма,
рекомендую воспользоваться специализированной универсальной программой FillDocuments

Достаточно нажать одну кнопку - чтобы создать и разослать множество персонализированных писем.

Для сохранения настроек почтового аккаунта запустите один раз этот макрос:

Sub SaveAccountData()    ' запускать один раз - для записи в реестр Windows параметров почтового аккаунта
    SaveSetting Application.Name, "mail", "smtpserver", "smtp.mail.ru"    ' Ваш SMTPServer
    SaveSetting Application.Name, "mail", "sendusername", "vasya_pupkin@mail.ru"    ' Ваша учетная запись
    SaveSetting Application.Name, "mail", "sendpassword", "pup123456"    ' Ваш  пароль
End Sub

Вместо использования макроса SaveAccountData, вы можете добавить в свой файл
форму сохранения и редактирования настроек учётной записи электронной почты

Function Send_Mail(ByVal MailTo As String, ByVal MailFrom As String, _
                   ByVal MailSubject As String, ByVal MailText As String, _
                   Optional ByVal MailAttachment As String = "") As Boolean
    ' функция для отправки почты без использования внешних почтовых программ
    ' ----------------------------------------------------------------------
    ' в качестве параметров получает:
    ' MailTo - адрес получателя письма
    ' MailFrom - адрес отправителя письма
    ' MailSubject - тема письма
    ' MailText - текст письма
    ' MailAttachment - полный путь к файлу вложения (необязательный параметр)
    ' ----------------------------------------------------------------------
    ' возвращает TRUE, если отправка почты произошла успешно, и FALSE в обратном случае

    Const cdoConfigURL = "http://schemas.microsoft.com/cdo/configuration/"
    On Error Resume Next: Err.Clear
 
    smtpserver = GetSetting(Application.Name, "mail", "smtpserver", "")
    sendusername = GetSetting(Application.Name, "mail", "sendusername", "")
    sendpassword = GetSetting(Application.Name, "mail", "sendpassword", "")
    If Len(smtpserver) = 0 Or Len(sendusername) = 0 Or Len(sendpassword) = 0 Then Exit Function
 
    Set cdoConfig = CreateObject("CDO.Configuration")
    With cdoConfig.Fields
        .Item(cdoConfigURL & "sendusing") = 2
        .Item(cdoConfigURL & "smtpauthenticate") = 1
        .Item(cdoConfigURL & "smtpserver") = smtpserver
        .Item(cdoConfigURL & "sendusername") = sendusername
        .Item(cdoConfigURL & "sendpassword") = sendpassword
        .Update
    End With
 
    Set cdoMessage = CreateObject("CDO.Message")
    With cdoMessage
        Set .Configuration = cdoConfig
        .BodyPart.Charset = "koi8-r"
        .From = MailFrom:
        .To = MailTo
        .Subject = MailSubject
        .TextBody = MailText
        If Len(MailAttachment) > 0 Then .AddAttachment MailAttachment
        .Send
    End With
    Set cdoMessage = Nothing: Set cdoConfig = Nothing
 
    '    If Err.Number = -2147220973 Then MsgBox ("Отсутствует связь с интернетом")
    '    If Err.Number = -2147220975 Then MsgBox ("SMTP сервер ответил отказом")
    '    If Err.Number = 0 Then MsgBox ("Письмо отправлено")
    Send_Mail = Err = 0
End Function

Дополнение: для отправки почты с аккаунта @gmail.com требуется добавить в код 2 строки

(указать номер порта, и разрешить аутентификацию)

With cdoConfig.Fields
    .Item(cdoConfigURL & "sendusing") = 2
    .Item(cdoConfigURL & "smtpauthenticate") = 1
    .Item(cdoConfigURL & "smtpserver") = SMTPserver
    .Item(cdoConfigURL & "sendusername") = sendusername
    .Item(cdoConfigURL & "sendpassword") = sendpassword
    ' для отправки почты с аккаунта @gmail.com
    .Item(cdoConfigURL & "smtpserverport") = 465 'порт для SSL: 465
    .Item(cdoConfigURL & "smtpusessl") = 1  'использовать аутентификацию: да
    .Update
End With

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Данный макрос нормально работает даже на Win10 + Office2016 Письма отправляются и доходят до получателя. Единственное но - выскакивает сообщение Не удалось отправить письмо... Может можно это допилить?)

При попытке отправки выдает номер ошибки -2147220977
Подскажите, пожалуйста что это.

"В Windows7 данный макрос работать не будет ввиду отсутствия библиотеки CDO for Windows 2000.
(потребуется ручная установка недостающей библиотеки)"

Скажите, пож., как это сделать?

Игорь, Спасибо !

Валерий,
вместо строки

If Len(MailAttachment) > 0 Then .AddAttachment MailAttachment

напишите несколько таких строк:
.AddAttachment "c:\folder\My Documents\file1.xls"
.AddAttachment "c:\folder\My Documents\file2.doc"
.AddAttachment "c:\folder\My Documents\картинка.jpg"

Добрый день.
Как с помощью вашего макроса отправить 2 или 3 файла во вложении ?

Добрый день!
Есть необходимость отправлять письмо с текстом и вложением.
Вложение - лист Excel (один активный лист из книги) без создания отдельного файла на ЖД.

Добрый день! Спасибо за материал. Есть вопрос. В 2008 году написал аналогичный макрос в VBA Excel 2003. Часто им пользовался в то время. Потом потребность исчезла. Сейчас снова потребовалось его использовать. Но на компе уже Excel 2010 и 2016 + Windows 7. Оба экселя после выполнения метода send закрываются без предупреждения. При этом тестовое письмо отправляется. Может быть, есть идеи где искать проблему?

Вопрос снят, разобрался...

Все настроил, работает под Win7 без проблем.
Единственный вопрос в имени отправителя.
На почту приходит письмо которое не отображает имя отправителя соответственно постоянно во входящих висит именно адрес емайла...
Можно как нибудь сделать чтобы имя пользователя тоже передавалось?

Игорь, спасибо. Разобрался, все работает. Действительно не обязательно иметь подключение к интернет.
Этого оказалось достаточно.
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 0
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtpserver"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = "port"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Update
End With

Здравствуйте, Сергей.
Увы, на этот счет подсказать не могу, - ни разу не пробовал отправлять письма без доступа в интернет.
Скорее всего, и без доступа к microsoft.com всё должно получиться, - если правильно задать настройки SMTP-сервера.

Добрый день!
Подскажите, будет ли работать данный способ рассылки в локальной сети без доступа рабочей станции к инету? SMTP-сервер локальный есть. Дома попробовал - все ОК. На работе - не хочет. Смущает вот это Const cdoConfigURL = "http://schemas.microsoft.com/cdo/configuration/". Я правильно понимаю, без доступа к microsoft.com ничего не получится?

Добрый день, подскажите как для винд 7 установить cdo.

Сегодня боролся и чуть не сломался
при добавлении атачмента, текст в письме страновился вопросиками, (без атачмента текст был красивыми русскими буковками), хотя местами сносило и сабджект и имя атачмента ...
на мысль об проблеме мультичастей как раз и навело
удалось побороть:

    ' Create a CDO Message object.
    Set MailMessage = CreateObject("CDO.Message")
    If Err.number <> 0 Then
        SendEMail = False
        Exit Function
    End If
    Err.Clear
    On Error GoTo 0
    With MailMessage
        .Subject = Subject
        .From = FromAddress
        .To = Recips(NRecip)
        .CC = ccAddr
 
        With .Configuration.Fields
            ' set up the SMTP configuration
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTP_Server
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTP_ServerPort
'.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = ServerUser
'.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = ServerUserPass
            .Item("http://schemas.microsoft.com/cdo/configuration/languagecode") = "ru"
            .Item("urn:schemas:mailheader:content-language") = "ru"
            .Item("http://schemas.microsoft.com/cdo/mailheader/content-type") = "text/html; charset=UTF-8"
            .Update
        End With
        .BodyPart.Charset = "UTF-8"
 
        If MailBody <> vbNullString Then
            .TextBody = MailBody
        End If
 
        If IsArray(Attachments) = True Then
            ' attach all the files in the array.
            For N = LBound(Attachments) To UBound(Attachments)
                ' ensure the attachment file exists and attach it.
                If Attachments(N) <> vbNullString Then
                    If Dir(Attachments(N), vbNormal) <> vbNullString Then
                        .AddAttachment Attachments(N)
                    End If
                End If
            Next N
        Else
            ' ensure the file exists and if so, attach it to the message.
            If Attachments <> vbNullString Then
                If Dir(CStr(Attachments), vbNormal) <> vbNullString Then
                    .AddAttachment Attachments
                End If
            End If
        End If
 
        On Error Resume Next
        Err.Clear
        ' Send the message
        .Send
        If Err.number = 0 Then
            SendEMail = True
        Else
            SendEMail = False
            Exit Function
        End If
    End With

Удалось за счет полной инициализации в самом начале конфигурации и, затем добавления Тела и атачмента сформировали правильный мультипарт и с правильной кодировкой.

удачи

Добрый день!
Подскажите, пожалуйста, как при отправке письма из Outlook сделать так, чтобы при создании письма из Ехсель с помощью VBA в письмо автоматически добавлялась подпись, та которая настроена у сотрудника для указания при создании новых сообщений. Заранее спасибо!!!

Павел, сделать всё можно.
Но это будет уже совершенно другой макрос, не имеющий ничего общего с приведенным в этой статье.

Извините, упустил этот комментарий. Тогда вопрос другой, у меня почта ходит в компании либо через NRPC либо через SMTP, в связи с тем, что под NRPC сложно что либо найти решил использовать этот вариант, потому что тут можно указать любую другую учетную запись. Есть варианты, как можно указать не текущую сессию, а другой логин и пароль и при этом шло бы сохранение сообщений в отправленных на сервере?

Здравствуйте, Павел.
В комментариях уже есть ответ на ваш вопрос: http://excelvba.ru/code/CDO#comment-1335
Вкратце: хотите чтобы на сервере сохранялись? Так через этот сервер тогда и отправляйте, а не напрямую с компа.

Здравствуйте, очень благодарен Вам за реализацию, сильно помогло в решении вопросов в работе, единственный вопрос, какую строку и куда прописать, что бы отправленные сообщения сохранялись на сервере и в дальнейшем были видны в папке "отправленные"

zOn, за воплощение своих фантазий надо платить, - либо временем, потраченным на обучение, либо наличными)

Если хотите получить помощь бесплатно, - обратитесь на форумы по Excel

конечно хочу получить :)
я ж макросах как жук в апельсинах, а фантазия прёт.

zOn, я ж не против, делайте
Или вы хотите получить готовый код?

Хочу макрос повесить на кнопку, что бы работал так:
1. выделяем ячейки (возможно не сплошной диапазон) с гиперссылками
2. жмем кнопку - формируется письмо с прикреплением файлов, на которые указывают гиперссылки.
3. ввод темы письма (либо автоматически формируется из имен файлов).
4. отправка.

kuda = "ivan_ivanov@mail.ru, vasya_pupkin@mail.ru"
otkogo = "mail@gmail.com"
If Send_Mail(kuda, otkogo, "проверка отправки почты", txt) Then
MsgBox smtxt & " получилась на ящики " & kuda, vbInformation
Else
MsgBox "Не удалось отправить письмо на ящики" & vbNewLine & _
kuda, vbExclamation
End If

Добрый день
Как правильно прописать в строке
If Send_Mail("ivan_ivanov@mail.ru", "vasya_pupkin@mail.ru", "проверка отправки почты", txt) Then
несколько постоянных адресатов? Например два или три.

Manless, весь необходимый код для отправки одного письма приведён в статье.

Надо только задать настройки вашего почтового аккаунта,
нарисовать в Excel табличку с данными,
и написать макрос, перебирающий все строки в цикле

Если хотите готовое решение, - оформляйте заказ на сайте,
прикрепляйте таблицу со списком email, и подробно описывайте, что и как должно работать.
(не забудьте указать логин и пароль к почте, с которой будет вестись отправка)
PS: Это уже не бесплатно, разумеется.

Здравствуйте,не могу создать макрос..вроде все делаею так как написано, но не понимаю почему не происходит. и как организовать табличку с почтой и вложениями?
Если можно напишите пожалуйста полностью код который надо вставить в module1..и как организовать ячейки в книге

Насчёт прокси - да, примерно так.
Тут я проверить код не могу - нет у меня прокси. Так что с этим разбирайтесь самостоятельно.

По удалению почтового аккаунта из реестра:
зачем удалять, если туда можно ничего не записывать?

Вместо этих строк в функции

    smtpserver = GetSetting(Application.Name, "mail", "smtpserver", "")
    sendusername = GetSetting(Application.Name, "mail", "sendusername", "")
    sendpassword = GetSetting(Application.Name, "mail", "sendpassword", "")
    If Len(smtpserver) = 0 Or Len(sendusername) = 0 Or Len(sendpassword) = 0 Then Exit Function

напишите так:
    smtpserver = "smtp.mail.ru"    ' Ваш SMTPServer
    sendusername = "vasya_pupkin@mail.ru"    ' Ваша учетная запись
    sendpassword = "pup123456"    ' Ваш  пароль

а макрос SaveAccountData вообще удалите

Как потом удалить из реестра все данные почтового аккаунта?

Правильно ли я понимаю, что нужно добавить такие строки в блок ????
with cdoConfig.Fields
...
.Item("http://schemas.microsoft.com/cdo/configuration/urlproxyserver").Value = "IP моего прокси"
.Item("http://schemas.microsoft.com/cdo/configuration/urlproxybypass").Value = "Пароль на прокси"
...
end with

Вопрос насчёт прокси уже задавался в комментах.

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

Ну так надо не только макрос Sub Main() в свой файл скопировать,
а и саму функцию отправки почты Function Send_Mail тоже поместить в ваш файл, ниже макроса Sub Main().

И всё чудесным образом сразу заработает (если корректно укажете адреса почты и пароли, в предварительно запущенном макросе Sub SaveAccountData()

Не нашел, где можно прикрепить файл
Буду обьяснять
Выскакивает окошко Compile error: Sub or Function not defined
Строка
Sub Main() ' Пример использования функции Send_Mail выделена желтой заливкой
Словосочетание
Send_Mail выделено синей заливкой

Нет, на WinXP все должно работать.
«Ругается» - какую ошибку выдает?

WinXP SP3, Excel2007 может какие то отличия для такого сочетания. Попробовал все, что здесь имеется. Ругается

Sheriff02, дело в том, что я, прежде всего, программист Excel, а вот во всех этих прокси и их настройке особо не разбираюсь
(и даже навскидку не скажу, как проверить, подходит ли этот прокси для отправки через него почты)

Может, вам надо не http прокси, а какой-то другой (например, smtp proxy)?
(почта, всё-таки, не по http протоколу отправляется)

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

Уважаемый администратор, пытаюсь "прикрутить" обход прокси (http прокси без авторизации), но никак не могу понять как. Очень прошу подсказку.

Ирина, всё можно обойти)

Решение можно найти здесь

cdoURLProxyBypass "http://schemas.microsoft.com/cdo/configuration/urlproxybypass"
cdoURLProxyServer "http://schemas.microsoft.com/cdo/configuration/urlproxyserver"

Появляется ошибка "Отсутствует связь с интернетом", доступ в интернет через прокси-сервер. Как-то можно это обойти?

Евгений, странно, что вообще что-то отправляется...

Во-первых, первым параметром вы указываете "MailTo" в кавычках, а надо - без них
Во-вторых, оператор Exit For завершает цикл после первой обработанной строчки.
В третьих, вместо Cells(2, i) надо писать Cells(i, 2) - чтобы цикл шел по столбцу, а не по строке.

Правильно будет так:

Sub ОтправкаПочты()
    txt$ = "Это письмо сформировано макросом" & vbNewLine & _
           "без использования внешних программ"
 
    For i = 2 To 100
        If Cells(i, 2) Like "*@*.*" Then   ' если в ячейке - адрес почты
            MailTo$ = Trim(Cells(i, 2).Value)
            ' отправляем письмо
            Send_Mail MailTo$, "vasya_pupkin@mail.ru", "тема письма", txt$
        End If
    Next i
End Sub

Советую вам попробовать специальную программу для рассылки почты:
http://excelvba.ru/programmes/FillDocuments/SendEmail
Там гораздо больше возможностей

Подскажите, в примере ниже пытался организовать рассылку почты, адреса которых расположены на листе во втором столбце начиная со второй строки. Письмо уходит только одному ( первому ) адресату. Подскажите, где ошибка??

Sub Main() ' Пример использования функции Send_Mail
txt = "Это письмо сформировано макросом" & vbNewLine & _
"без использования внешних программ и подключения дополнительных библиотек"

For i = 2 To 100

If (Cells(2, i).Value) > 0 Then
MailTo = Cells(2, i).Value

If Send_Mail("MailTo", "vasya_pupkin@mail.ru", "проверка отправки почты", txt) Then
MsgBox "Письмо успешно отправлено", vbInformation
Else
MsgBox "Не удалось отправить письмо", vbExclamation
End If

Exit For

End If

Next i

End Sub

СПАСИБО за столь быстрый и исчерпывающий ответ, ошибка пропала.

Евгений, если вы переведёте на русский текст сообщения об ошибке, то сразу станет ясно, что вы указали недостаточно аргументов (параметров) при вызове функции.

Функция Send_Mail принимает 4 ОБЯЗАТЕЛЬНЫХ параметра (все 4 надо указывать):

  • MailTo - адрес получателя письма
  • MailFrom - адрес отправителя письма
  • MailSubject - тема письма
  • MailText - текст письма

Если вы хотя бы один из этих параметров не задали - будет выдано указанное вами сообщение об ошибке.

У все так хорошо работает макрос, и ни у кого не возникало ошибки: Argument not optional (Error 449)??? Что это может быть???
The number and types of arguments must match those expected. This error has the following causes and solutions:
-Incorrect number of arguments.
-Omitted argument isn't optional.

Великолепный пример! Даже не думал, что так просто.

Что нужно для прокси-сервера дописывать ?

Так и должно быть - письма отправляются напрямую из Windows, без использования каких-либо почтовых сервисов или программ.
Так что, эти письма не появятся нигде в исходящих. (потому что отправителем является ваша операционная система, и никто больше не знает о факте отправки этих писем)

Работает!
Только на mail.ru у получателя письма во входящих оно есть, а у отправителя в отправленных его нет.

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
   ___    _                   _____   _____ 
( _ ) | |_ ___ __ __ | ___| |_ _|
/ _ \ | __| / _ \ \ \/ / | |_ | |
| (_) | | |_ | __/ > < | _| | |
\___/ \__| \___| /_/\_\ |_| |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.