Отправка почты макросом Excel

[The_Prist]

Сообщение от valerij

Да, написано, но почему тогда он, макрос, не указывает, типа "С запрошенным действием не связана программа электронной почты. Установите программу электронной почты или, если она уже установлена, создайте связь в панели управления "Программы по умолчанию"?

Да потому что там макрос сам обращается именно к Outlook и все равно что там по умолчанию установлено(не установлено), отправлено будет именно через Outlook!
А приведенный мной пример обращается именно к почтовой программе по умолчанию. Теперь понятна разница?

[valerij]

Сообщение от The_Prist

Да потому что там макрос сам обращается именно к Outlook и все равно что там по умолчанию установлено(не установлено), отправлено будет именно через Outlook!
А приведенный мной пример обращается именно к почтовой программе по умолчанию. Теперь понятна разница?

Prist!!
Супер понятно, СПАСИБО!!!!!
Так не охота эту дребедень(Outlook, Бат ...) ставить...
Может doober, сделает и в сети куча макросов и все либо с Outlook, либо не работают.

[doober]

Извените за задержку,под вечер тяжело пробиться в интернет
Проверил работает.Главное правильно укажите Smtp сервер,учетную запись и пароль.Если что не получится пишите в личку,и сразу свое мыло,есть особенности в SMTP серверах.
В референсах добавить ссылку на
Microsoft CDO for Windows 2000 Library

Sub My_send()

    Dim WB As Workbook
    Dim ind As Integer
   ind = ActiveSheet.Index
     Application.DisplayAlerts = False
        Set WB = Workbooks.Add   ' создаём новую книгу
    Dim li As Long
    Application.DisplayAlerts = False
    For n = ind To 1 Step -1
      ThisWorkbook.Sheets(n).Copy Before:=WB.Sheets(1)
    Next
    WB.SaveAs Application.DefaultFilePath & Application.PathSeparator & "На_Отпраку.xls", xlNormal
    WB.Close False
    Application.DisplayAlerts = True
    Set cdoConfig = CreateObject("CDO.Configuration")
 
    With cdoConfig.Fields
    .Item(cdoSendUsingMethod) = cdoSendUsingPort
     
       .Item(cdoSMTPAuthenticate) = 1
       .Item(cdoSMTPServer) = "mail.rambler.ru" ' Ваш SMTPServer
       .Item(cdoSendUserName) = "Vasya" ' Ваша учетная запись
        .Item(cdoSendPassword) = "111111" ' Ваш  пароль
        .Update
    End With
 
    Set cdoMessage = CreateObject("CDO.Message")
 
    With cdoMessage
       On Error Resume Next
    
        Set .Configuration = cdoConfig
        .From = "Vasya@rambler.ru" ' отправитель
        
        .To = "Vasya2@rambler.ru" 'Получатель.Если не один то через запятую
        .Subject = "Здесь тема письма"
        .TextBody = "текст тела письма"
        .AddAttachment Application.DefaultFilePath & Application.PathSeparator & "На_Отпраку.xls" ' Добавляем файл
        .Send
    End With
  If Err.Number = -2147220973 Then
        MsgBox ("Отсутствует связь с интернетом")
    End If
    If Err.Number = -2147220975 Then
           MsgBox ("SMTP сервер ответил отказом")
    End If
    Set cdoMessage = Nothing
    Set cdoConfig = Nothing

 If Err.Number = 0 Then
       MsgBox ("Письмо отправлено")
End If
  Kill Application.DefaultFilePath & Application.PathSeparator & "На_Отпраку.xls"
End Sub

[valerij]

Сообщение от doober

В референсах добавить ссылку на
Microsoft CDO for Windows 2000 Library

doober!
А нет у меня Microsoft CDO for Windows 2000 Library, а почему?

Microsoft Office 2003, может потому, что при установки выбран тока эксель и ворд?

[doober]

Не може цього бути

только если у Вас Винда 95 -98
с 2000 эта библиотека присутствует
Не знаю как в Висте

[doober]

Поищите в Папке WINDOWS SYSTEM 32 cdosys.dll

[valerij]

Сообщение от doober

Поищите в Папке WINDOWS 32 cdosys.dll

У меня 7, нашел, просто переставил офис с Расширенная настройка приложений.
Но ошибка
Set cdoConfig = CreateObject("CDO.Configuration")

[doober]

Значит в 7 есть другая библиотека.Пороюсь на просторах,поищу что нибудь.

[EducatedFool]

Немного переработал функцию, предложенную doober
(давно искал подобную функцию - которой для отправки почты не нужны почтовые программы)

Вот что получилось: http://excelvba.ru/code/CDO

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

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


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

Добавил строку .BodyPart.Charset = "koi8-r" - без неё в письме приходили кракозябры (получал почту при помощи TheBat!)

Ну и заменил все константы в коде их значениями - чтобы не требовалась ссылка на библиотеку Microsoft CDO for Windows 2000 Library

Код проверил - работает замечательно.

[valerij]

Сообщение от EducatedFool

Вот что получилось:.

Ну что, такое....
Заменил своими, красным

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

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

Пишет:
"Не удалось отправить письмо"