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

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)

- Microsoft Office (Word, Excel, Outlook и т.д.) (http://forum.oszone.net/forumdisplay.php?f=115)

Отправка писем из списка адресов Excel

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

Можно.

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

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

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

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

Iska,
Начал тестить, первый камень в огороде

Цитата:

Цитата B1010

Начал тестить, первый камень в огороде »

Добавьте в конфигурацию строку:

Код:

.Item(strSchema & "smtpusessl") = True

Укажите правильный номер порта для используемого сервера с шифрованием (например, Mail.RU, Yandex — 465).

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

Цитата:

Цитата B1010

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

Я уже проверял :).