Отправка e-mail уведомления по условию

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Отправка e-mail уведомления по условию (Макросы/Sub)

VIDEO56

Дата: Среда, 26.08.2015, 13:18 | Сообщение № 1

Группа: Проверенные

Ранг: Обитатель

Сообщений: 262

Репутация: 23 ±

Замечаний: 0% ±

Excel 2010

Добрый день!
Прошу помочь в решении задачи. Есть файл который на ежедневной основе ведут менеджеры. Задача в следующем при введении суммы оплаты факт в столбце Q формировалось письмо с указанием клиента в этой же строке из столба А, номера договора (столб Н), и рассылка была привязана к двум почтовым адресам, и указанием пути к файлу где лежит заявка (например корень диска С).

К сообщению приложен файл: 7419908.xlsm (16.2 Kb)

Всем удачного дня!

Сообщение отредактировал VIDEO56 - Среда, 26.08.2015, 13:19

Ответить

KSV

Дата: Среда, 26.08.2015, 22:18 | Сообщение № 2

Группа: Друзья

Ранг: Ветеран

Сообщений: 770

Репутация: 255 ±

Замечаний: 0% ±

Excel 2013

Добрый вечер!
Можно так: [vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
      If Target.Column <> 17 Then Exit Sub
      Dim r&: r = Target.Row: If r < 3 Then Exit Sub
      With CreateObject("Outlook.Application")
          With .CreateItem(0)
              .To = "e-mail1@domain.com; e-mail2@domain.com "
              .Subject = "Оплата по договору № " & Cells(r, 8) & " от " & Cells(r, 11) & "   " & Cells(r, 1)
              .Body = "Контрагент: " & Cells(r, 1) & vbCrLf & _
                      "Договор № " & Cells(r, 8) & " от " & Cells(r, 11) & vbCrLf & _
                      "Сумма по договору: " & Cells(r, 9) & vbCrLf & _
                      "Оплачено: " & Cells(r, 17) & "   (" & Cells(r, 16) & ")"
              .Attachments.Add "C:\FileName.ext"
              '.Display ' если нужно посмотреть письмо
              .Send
          End With
          .Quit
      End With
End Sub

[/vba]

К сообщению приложен файл: 8922811.xlsm (24.3 Kb)

KSV.VBA@gmail.com
Яндекс.Деньги: 410011921213333

Сообщение отредактировал KSV - Среда, 26.08.2015, 22:57

Ответить

EvgenyD

Дата: Среда, 26.08.2015, 22:25 | Сообщение № 3

Группа: Пользователи

Ранг: Участник

Сообщений: 74

Репутация: 19 ±

Замечаний: 0% ±

Excel 2013

VIDEO56, если воспользоваться поиском, то вариантов организации отправки e-mail найдете не один.
Я пользуюсь таким:
[vba]

Код

Sub Send_Mail()
     Const CDO_Cnf = "http://schemas.microsoft.com/cdo/configuration/"
     Dim oCDOCnf As Object, oCDOMsg As Object
     Dim SMTPserver As String, sUsername As String, sPass As String, sMsg As String
     Dim sTo As String, sFrom As String, sSubject As String, sBody As String, sAttachment As String, Header As String
     'On Error Resume Next
     'sFrom – как правило совпадает с sUsername
     SMTPserver = "smtp.yandex.ru"    ' SMTPServer: для Mail.ru "smtp.mail.ru"; для Яндекса "smtp.yandex.ru"; для Рамблера "mail.rambler.ru"
     sUsername = ""    ' Учетная запись на сервере
     sPass = ""    ' Пароль к почтовому аккаунту

     If Len(SMTPserver) = 0 Then MsgBox "Не указан SMTP сервер", vbInformation, "Недостаточно данных": Exit Sub
     If Len(sUsername) = 0 Then MsgBox "Не указана учетная запись", vbInformation, "Недостаточно данных": Exit Sub
     If Len(sPass) = 0 Then MsgBox "Не указан пароль", vbInformation, "Недостаточно данных": Exit Sub

     sTo = ""    'Кому
     sFrom = ""    'От кого
     sSubject = ""   'Тема письма
     sBody = ""    'Текст письма
     sAttachment = ""    'Вложение(полный путь к файлу)
     'Проверка наличия файла по указанному пути
     If Dir(sAttachment, vbDirectory) = "" Then sAttachment = ""
     'Назначаем конфигурацию CDO
     Set oCDOCnf = CreateObject("CDO.Configuration")
     With oCDOCnf.Fields
         .Item(CDO_Cnf & "sendusing") = 2
         .Item(CDO_Cnf & "smtpauthenticate") = 1
         .Item(CDO_Cnf & "smtpserver") = SMTPserver
         'если необходимо указать SSL
         .Item(CDO_Cnf & "smtpserverport") = 25 'для Яндекса и Gmail 465
         .Item(CDO_Cnf & "smtpusessl") = True
         '=====================================
         .Item(CDO_Cnf & "sendusername") = sUsername
         .Item(CDO_Cnf & "sendpassword") = sPass
         .Update
     End With
     'Создаем сообщение
     Set oCDOMsg = CreateObject("CDO.Message")
     With oCDOMsg
         Set .Configuration = oCDOCnf
         .BodyPart.Charset = "koi8-r"
         .From = sFrom
         .To = sTo
         .Subject = sSubject
         .HTMLBody = "<html><body><div>" & sBody & "</div></body></html>"
         '.TextBody = sBody
         If Len(sAttachment) > 0 Then .AddAttachment sAttachment
         .send
     End With

     Select Case Err.Number
     Case -2147220973: sMsg = "Нет доступа к Интернет"
     Case -2147220975: sMsg = "Отказ сервера SMTP"
     Case 0: sMsg = "Письмо отправлено"
     End Select
     'MsgBox sMsg, vbInformation
     Set oCDOMsg = Nothing: Set oCDOCnf = Nothing
End Sub

[/vba]

Код