[решено] Отправка писем из списка адресов Excel

[B1010]

Имеется некий список E-Mail адресов, и для каждого адреса имеется определённый текст, который нужно отправить именно ему. Проблема в том, что адреса постоянно разные. Возможно ли составить VB скрипт который это будет делать?

[Iska]

Можно.

Код будет после предоставления образца «списка E-Mail адресов» и описания алгоритма соответствия конкретного адреса конкретному «определённому тексту».

[B1010]

Конечно, но только в личку, так как я не имею права его распространять публично.

Iska,
Не могу отправить в личку, у вас превышен лимит на сообщения)

[Iska]

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

[B1010]

Без проблем, приложил к сообщению

[Iska]

Например, так:
Option Explicit

Sub SendMassMail()
Const cdoSendUsingPort = 2
Const cdoBasic = 1

Const strSchema = "http://schemas.microsoft.com/cdo/configuration/"

Dim objRange As Range

If IsConnected() Then
For Each objRange In ThisWorkbook.Worksheets.Item("Лист1").UsedRange.Columns.Item(1).Cells
With CreateObject("CDO.Message")
.From = "myaccount@mail.ru"
.To = objRange.Value
.Subject = "Some Sobject"
.Textbody = objRange.Offset(0, 1).Value

With .Configuration.Fields
.Item(strSchema & "smtpserver") = "smtp.mail.ru"
.Item(strSchema & "sendusing") = cdoSendUsingPort
.Item(strSchema & "smtpserverport") = 25
.Item(strSchema & "smtpauthenticate") = cdoBasic
.Item(strSchema & "sendusername") = "myaccount@mail.ru"
.Item(strSchema & "sendpassword") = "mypassword"

.Update
End With

.Send
End With
Next
End If
End Sub

Function IsConnected()
Dim objSWbemObjectEx

IsConnected = False

For Each objSWbemObjectEx In GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2").ExecQuery("SELECT * FROM Win32_PingStatus WHERE Address = 'www.google.com'")
With objSWbemObjectEx
If Not IsNull(.StatusCode) And .StatusCode = 0 Then
IsConnected = True
End If
End With

Exit For
Next

Set objSWbemObjectEx = Nothing
End Function

[B1010]

Iska,
Спасибо вам огромное, оказали большую услугу!

[B1010]

Iska,
Начал тестить, первый камень в огороде (https://imgdepo.com/show/9240344)

[Iska]

Начал тестить, первый камень в огороде »
Добавьте в конфигурацию строку:
.Item(strSchema & "smtpusessl") = True
Укажите правильный номер порта для используемого сервера с шифрованием (например, Mail.RU, Yandex — 465).

[B1010]

Iska,
Спасибо, буду проверять

[Iska]

Iska, Спасибо, буду проверять »
Я уже проверял :).