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

[kserems]

Специалисты, откликнитесь пожалуйста!

Очень надо, расчётную часть проекта я сделал, осталось допилить автоматизацию обработки данных и отправки сообщения с вложением.
По вопросу автоматизации обработки данных надеюсь вопросов не возникнет (надеюсь что получится записать макрос средствами Excel, пока не брался) , а вот с отправкой сообщения возникли сложности, т.к. в этой области я абсолютный ноль.

Повторю вопрос на всякий случай:

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

Ниже макрос, письмо создает, но как прикрепить к нему диапазон ячеек с активного листа не могу понять.

Sub SendMail()  
    Dim OutApp As Object  
    Dim OutMail As Object  
    Dim cell As Range  
      
    Application.ScreenUpdating = False  
    Set OutApp = CreateObject("Outlook.Application")  
    OutApp.Session.Logon  
    On Error GoTo cleanup  
    Set OutMail = OutApp.CreateItem(0)  
    On Error Resume Next  
      
    With OutMail  
        .To = Range("A1").Value  
        .Subject = Range("A2").Value  
        .Body = Range("A3").Value  
        .Attachments.Add Range("A4").Value  
        'команду Send можно заменить на Display, чтобы посмотреть сообщение перед отправкой   
        .Send  
    End With  
  
    On Error GoTo 0  
    Set OutMail = Nothing  
  
cleanup:  
    Set OutApp = Nothing  
    Application.ScreenUpdating = True  
End Sub

[kserems]

Добрый день!

Выкладываю решение моего вопроса (помогли на другом форуме), может кому пригодится.

Sub Sendmail_ActiveBook() 
Dim OutApp As Object, wbTemp as Workbook 
Dim OutMail As Object 
Dim cell As Range 
 
Application.ScreenUpdating = False 
Application.EnableEvents=false 
Application.DisplayAlerts=false 
 
Set wbTemp=Workbooks.Add 
ThisWorkbook.Activate 
Set OutApp = CreateObject("Outlook.Application") 
OutApp.Session.Logon 
On Error GoTo cleanup 
Set OutMail = OutApp.CreateItem(0) 
On Error Resume Next 
 
ActiveWorkbook.ActiveSheet.Copy Before:=wbTemp.Worksheets(1) 
wbTemp.SaveAs ("C:\Temp\имя файла.xls") 
wbTemp.Close 
 
 
With OutMail 
.To = Range("Q2").Value 
.Subject = Range("Q3").Value 
.Body = Range("Q4").Value 
.Attachments.Add ("C:\Temp\имя файла.xls") 
.Display 
End With 
 
On Error GoTo 0 
Set OutMail = Nothing 
 
cleanup: 
Set OutApp = Nothing 
Kill ("C:\Temp\имя файла.xls") 
 
Application.EnableEvents=True 
Application.DisplayAlerts=True 
Application.ScreenUpdating = True 
End Sub

Благодарю поучавствовавших.

[strannick]

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

а дописать одну команду для отправки сложно?
http://programmersforum.ru/showpost....98&postcount=2

обратите внимание на последнюю строку в коде

Возвращаясь к командной строке программы The Bat!: я так понимаю, что для того, чтобы отправить почту не с ящика, определенного "по умолчанию", а с какого-либо другого, необходимо в макросе к команде " /MAIL;" приписать имя того самого ящика. Вот не понял как правильно приписать (синтаксис). И еще вопрос: а нельзя ли прописать имя этого ящика в соответствующей ячейке и брать оттуда?

[EducatedFool]

Вот не понял как правильно приписать (синтаксис)

Не ведь в том моём сообщении есть ссылка на описание параметров командной строки TheBAT... что ещё-то нужно?

АВТОМАТИЗИРОВАННОЕ СОЗДАНИЕ СООБЩЕНИЯ - КОМАНДА /MAIL

Команда /MAIL используется для автоматизированного создания сообщения из
шаблона, текстового файла и/или набора присоединенных файлов на
определенный адрес. Эта команда чрезвычайно полезна для приложений, которые
требуют посылки сообщений электронной почты без вмешательства пользователя,
в соответствии со стандартами сети Интернет. Синтаксис команды /MAIL:
/MAIL [parameter1[;parameter2[;parameter3 [...]]]

Возможные параметры:
USER=значение или U=значение. Значение - название ящика, из которого
должно быть отправлено сообщение. Если параметр FOLDER не определен, будет
отправлено сообщение из папки Inbox данного ящика.

Читаем этот текст внимательно 28 раз, и пробуем:

' ....
strUSER = "USER=" & Chr(34) & "Название нужного ящика" & Chr(34)
' ....

' формируем командную строку
    Cmd = TheBatPath & " /MAIL;" & strUSER & ";" & strTO & ";" & strSUBJECT & ";" & strTEXT & ";" & strATTACH & " /SENDALL; /MINIMIZE;"

' ...

И еще вопрос: а нельзя ли прописать имя этого ящика в соответствующей ячейке и брать оттуда?

Можно.
В коде это будет выглядеть как-то так:

strUSER = "USER=" & Chr(34) & range("a3") & Chr(34)

[valerij]

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

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

Игорь!
?, почему(у меня на работе) с др. провайдером пишет: "Не удалось отправить письмо" и письма нет.

Приношу с работы - домой ПК, всё ОК!!!
Где "копать"?

[EducatedFool]

Где "копать"?

1) В настройках Windows (есть библиотека CDO? Используется WinXP?)
2) В настройках антивируса
3) В настройках прокси-сервера
4) В своих мозгах)

В теме приведено множество разных макросов - я догадаться должен, про какой из них идет речь?

[valerij]

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

я догадаться должен, про какой из них идет речь?

Все 4 - ри пункта не подходят, а макрос, вот под W7

Sub SendAttachment()
    Application.DisplayAlerts = False
        iFileName$ = ThisWorkbook.path & "\Avto XXXX " & ".xls"
            ThisWorkbook.SaveCopyAs Filename:=iFileName$
        If Send_Mail("xxxxx@yandex.ru", "xxxxx@yandex.ru", "Учет-Авто", iFileName$) Then
            MsgBox "Письмо успешно отправлено", vbInformation, ""
                Else
            MsgBox "Не удалось отправить письмо", vbCritical, ""
        End If
            Kill PathName:=iFileName$
    Application.DisplayAlerts = True
End Sub
Function Send_Mail(ByVal MailTo As String, _
                   ByVal MailFrom As String, _
                   ByVal MailSubject As String, _
                   ByVal MailAttachment As String, _
                   Optional ByVal MailText As String = "") As Boolean
    Const cdoConfigURL = "http://schemas.microsoft.com/cdo/configuration/"
    Const SmtpServer = "smtp.yandex.ru"
    Const SendUsername = "xxxxxx@yandex.ru"
    Const SendPassword = "xxxxxxxxxxx"
    On Error Resume Next
    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
        .AddAttachment MailAttachment
        .Send
    End With
    Set cdoMessage = Nothing: Set cdoConfig = Nothing
    Send_Mail = (Err.Number = 0)
End Function

[EducatedFool]

Валера, код функции опубликован здесь:
http://excelvba.ru/code/CDO
(в том сообщении на форуме была ссылка)

Почитай внимательно первые предложения в статье:

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

[valerij]

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

Почитай внимательно первые предложения в статье:

Игорь, ну конечно же я всё читал.
Дома, та же 7 и все работает, на работе только провайдер другой и скорость по <<.

[valerij]

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

В Windows7 данный макрос работать не будет ввиду отсутствия библиотеки CDO for Windows 2000.

Кстати, библиотека CDO for Windows 2000 в W7SP1, присутствует!!!