ВНИМАНИЕ! Данный код гарантированно работает ТОЛЬКО в ОС 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
Для сохранения настроек почтового аккаунта запустите один раз этот макрос:
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
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
Комментарии
Работает! Благодарю!
Александр, вы перемудрили с кодом...
Ваши ошибки:
1) в Word нет метода SaveCopyAs, поэтому эта строка не работала
2) Вы сохраняли документ через SaveAs, и потом пытались отправить этот же (открытый в Word) файл по почте. А открытый файл невозможно отправить таким способом.
Вот так будет работать:
(чтобы получить закрытый файл под другим именем, я его сначала сохраняю текущий документ под новым именем, а потом снова под исходным.)
On Error Resume Next: ActiveDocument.Save ' сохраняем документ Word
OLD_filename = ActiveDocument.FullName
' формируем путь к папке, куда будет помощена копия файла (в виде архива)
BackupsPath = Replace(ActiveDocument.FullName, ActiveDocument.Name, "Backups\")
MkDir BackupsPath ' создаём папку, если таковой ещё нет
ext$ = Split(ActiveDocument.Name, ".")(UBound(Split(ActiveDocument.Name, ".")))
' формируем путь для копии файла Word
NEW_filename = BackupsPath & "document" & "_" & Format(Now, "DD-MM-YYYY") & "." & ext$
ActiveDocument.SaveAs NEW_filename
ActiveDocument.SaveAs OLD_filename
txt = "----------------" & vbNewLine & "_____________"
smtxt = "_____________________ за " & Format(Now, "DD-MM-YYYY")
kuda = "some@gmail.com": otkogo = "fromme@yandex.ru"
If Send_Mail(kuda, otkogo, smtxt, txt, NEW_filename) Then
MsgBox smtxt & " успешно отправлен по адресу " & kuda, vbInformation
Else
MsgBox "Не удалось отправить письмо, возможно, отсутствует интернет-связь." & vbNewLine & NEW_filename, vbExclamation
End If
End Sub
Xls отправляется. Скопировал макрос в doc Файл, изменил book на document, xls на doc. Получил сообщение: Возможно, отсутствует интернет-связь. Посмотрите пожалуйста, что не так: http://zalil.ru/33237731
Смотри ниже таблицы, ссылки в зависимости от версии оутлука.
Кто поделится ссылкой на библиотеку CDO for Windows 2000
Не смог сам найти.
Здравствуйте, Алексей.
К сожалению, вряд ли смогу вам помочь, - у меня нет Exchange-сервера, и протестировать код не на чем.
Я бы на вашем месте попробовал указать не имя, а IP адрес вашего сервера в параметре SMTPServer.
И ещё - у вас выход в интернет идет через прокси-сервер?
(если да - то в код надо добавить ещё пару строк)
Лучше вам задать вопросы о настройках этого кода вашему системному администратору (кому, как не ему, знать все настройки вашего почтового сервера)
Например, для использования этого кода с Google или mail.ru, необходимо указать специфические параметры
(например, номер порта, и ещё там что-то, не помню уже)
Возможно, в вашем случае тоже нехватает изменения одной цифры.
Здравствуйте.
Попробовал на корпоративный Exchange-сервер отправить. Поле ' Ваш SMTPServer заполнял и с префиксом домена (mailXX.kostal.int) так и без (mailXX) - выдает ошибку "SMTP сервер ответил отказом". Файрвол отключен.
Помогите плиз.
Изучайте объектную модель CDO for Windows 2000:
(щелкните на картинке для увеличения)
Видимо, потребуется дополнительно сменить свойство Charset у другого объекта
(у какого конкретно - не знаю, описания всех методов и свойств CDO я так и не нашел)
Подскажи, пожалуйста, решение такой проблемы.
Реализовал отправку при помощи CDO, немного другой код (без страницы конфигурации от Windows, т.к. почтовый сервер у меня в сетке).
Все работает, но Тему и имя вложения (которые на русском языке) пишет "кракозябрами".
Как задать кодировку тела письма понятно (SMail.BodyPart.Charset = "windows-1251"), а как задать кодировку темы и имени вложения (не нашел метода)?
Спасибо.
Спасибо, очень нужная функция!
Спасибо. Работает, все и сразу, с одного нажатия.
1) Создаёте копию активного листа:
2) Сохраняете созданный файл из одного листа куда-нибудь на диск:
activeworkbook.close false ' и закрываете файл
3) Прикрепляете сохранённый файл (как любой другой файл) к письму
К качестве пути прикрепляемого файла используете переменную Путь$
А как сделать? Чтобы вместо вложения отправить активный лист. или добавить
Спасибо большое за макрос, использую его теперь для действия в полуавтоматическом режиме: импортирую накладную из Foxpro 2.6 и отправляю по эл. почте
Спасибо за макрос. Здорово получается..
Причин может быть несколько.
Например, наличие прокси-сервера, ненастроенный файрвол, глюк Windows или сбой в системных файлах.
Наиболее вероятная причина - что Excel пытается выйти в интернет, а антивирус со встроенным файрволом (типа KIS) его не пускает.
Добрый день!
Из-за чего функция Send_Mail может выдавать ошибку отсутствия соединения с интернетом, при его наличии? Проверил на разных компах одной сети. Результат: 3 успешно, 1 с ошибкой (-2147220973 MsgBox "Отсутствует связь с интернетом").
Операционка одинаковая - ХР.
Огромное спасибо за коды макросов - очень много полезного!
Огромное спасибо за код. Работает прекрасно
А из-за Proxy работать будет?
У меня на работе прокси, плюс запрещен доступ к mail.ru.
Как вы считаете можно решать эту проблему?
Скрытая копия отправляется по полю
.BCC="типа мыло"
Спасибо за код! Подскажите, а как можно поместить адресата в скрытую копию?возможно ли такое?
Работает в вин7. проверил только на корпоративном smtp сервере. mail.ru не проверял
Нужно только подключить библиотеку CDO for Windows 2000
Отправить комментарий