Макрос рассылка на различные адресаты

[KevLev]

Всем привет!Возник вопрос по макросу - рассылке на разные почтовые адресаты. Есть макрос:

SUB SendMail
Dim objEmail
Const cdoSendUsingPort = 2 ' Send the message using SMTP
Const cdoBasicAuth = 1 ' Clear-text authentication
Const cdoTimeout = 60 ' Timeout for SMTP in seconds
mailServer = "smtp.gmail.com"
SMTPport = 465
mailusername = "maximprusov2000@gmail.com"
mailpassword = "**********" 'your password
mailto = "mprusov@mail.ru;kevlevmax@yandex.r u;gdigdalo@mail.ru"
mailSubject = "Subject line"
mailBody = "This is the email body"
Set objEmail = CreateObject("CDO.Message")
Set objConf = objEmail.Configuration
Set objFlds = objConf.Fields
With objFlds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = mailServer
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTPport
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = cdoTimeout
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasicAuth
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = mailusername
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = mailpassword
.Update
End With
objEmail.To = mailto
objEmail.From = mailusername
objEmail.Subject = mailSubject
objEmail.TextBody = mailBody
objEmail.AddAttachment "Z:\Maksim\Macro.xlsx"
objEmail.Send
Set objFlds = Nothing
Set objConf = Nothing
Set objEmail = Nothing

end sub

Если кто сталкивался,подскажите пожалуйста,что нужно изменить в макросе,чтобы РАЗЛИЧНЫЕ файлы xlsx рассылались ОПРЕДЕЛЕННЫМ адресатам? На данный момент,я могу только отсылать один эксель файл "Macro.xlsx" на 3 адреса.Спасибо за внимание к вопросу!

[Aleksandr H.]

сформируйте массив: A(0)название файла; A(1)список адресатов. И в цикле формируйте текст письма

[KevLev]

Александр спасибо за ответ!Если не трудно,можно подробнее указать,каким образом это сделать.К сожалению с макросами встречаюсь впервые и опыт нулевой.Спасибо за понимание!

[Aleksandr H.]

Попробуйте такой вариант:

Sub SendMail()
    Dim objEmail
    Const cdoSendUsingPort = 2 ' Send the message using SMTP
    Const cdoBasicAuth = 1 ' Clear-text authentication
    Const cdoTimeout = 60 ' Timeout for SMTP in seconds
    Dim a(1, 5) As String
    a(0, 0) = "mprusov@mail.ru": a(1, 0) = "Z:\Maksim\Macro.xlsx"
    a(0, 1) = "kevlevmax@yandex.ru": a(1, 1) = "Z:\Maksim\Macro.xlsx"
    a(0, 2) = "gdigdalo@mail.ru": a(1, 2) = "Z:\Maksim\Macro.xlsx"
    a(0, 3) = "mprusov@mail.ru;kevlevmax@yandex.ru": a(1, 3) = "Z:\Maksim\Macro.xlsx"
    a(0, 4) = "mprusov@mail.ru;kevlevmax@yandex.ru;gdigdalo@mail.ru": a(1, 4) = "Z:\Maksim\Macro.xlsx"
    a(0, 5) = "mprusov@mail.ru;gdigdalo@mail.ru": a(1, 5) = "Z:\Maksim\Macro.xlsx"
    
    For i = 0 To 5
        mailServer = "smtp.gmail.com"
        SMTPport = 465
        mailusername = "maximprusov2000@gmail.com"
        mailpassword = "**********" 'your password
        mailto = a(0, i) '"mprusov@mail.ru;kevlevmax@yandex.r u;gdigdalo@mail.ru"
        mailSubject = "Subject line"
        mailBody = "This is the email body"
        Set objEmail = CreateObject("CDO.Message")
        Set objConf = objEmail.Configuration
        Set objFlds = objConf.Fields
        With objFlds
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = mailServer
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTPport
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = cdoTimeout
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasicAuth
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = mailusername
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = mailpassword
            .Update
        End With
        objEmail.To = mailto
        objEmail.From = mailusername
        objEmail.Subject = mailSubject
        objEmail.TextBody = mailBody
        objEmail.AddAttachment a(1, i) '"Z:\Maksim\Macro.xlsx"
        objEmail.Send
    Next
    Set objFlds = Nothing
    Set objConf = Nothing
    Set objEmail = Nothing
    
End Sub

а можете на листе xls в 2 колонки сделать список : адресат-путь к вложению, и оттуда брать, а не с массива.

[KevLev]

Александр,сделал,как вы написали.К сожалению появилась ошибка Можно каким то образом исправить?

[Aleksandr H.]

Можно, только надобно знать что за ошибка, в какой строке, иметь файла откуда запускаете макрос.

[KevLev]

Ошибка в строке Dim a(1, 5) As String .При запуске макроса пишет "Expected end of statement".

[KevLev]

кажется as Sting надо удалить

[Aleksandr H.]

Ну удалите. Пускай vba сам определяет как ему удобнеея запускал код у себя, ошибка была только на отсутствие файла

[KevLev]

Александр сработало!Спасибо вам за внимание к вопросу!Очень помогли!