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

[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 адреса.Спасибо за внимание к вопросу!
К сожалению с макросами встречаюсь впервые и опыт нулевой.Спасибо за понимание!

[pashulka]

Замените

Код: Выделить всё

objEmail.To = mailto
objEmail.From = mailusername
objEmail.Subject = mailSubject
objEmail.TextBody = mailBody
objEmail.AddAttachment "Z:\Maksim\Macro.xlsx"
objEmail.Send

На (почту и файлы укажите реально существующие)

Код: Выделить всё

iArr1 = Array("mprusov@mail.ru", "kevlevmax@yandex.ru", "gdigdalo@mail.ru")
iArr2 = Array("C:\Maksim\File1.xlsx", "C:\Pavel\File2.xlsx", "C:\Nick\File3.xlsx")

objEmail.From = mailusername
objEmail.Subject = mailSubject
objEmail.TextBody = mailBody

For iCount = 0 To UBound(Arr1)
    objEmail.To = iArr1(iCount)
    objEmail.AddAttachment iArr2(iCount)
    objEmail.Send
Next

P.S. Если адресов и файлов много, то для их перечисления имеет смысл использовать ячейки MS Excel.

[KevLev]

Спасибо большое!Помогло)

[Housebond]

Спасибо большое!Помогло)

У вас еще работает этот макрос? Переделал его на VBS и при отправке сценарий подвисает и не выдает никакую ошибку. Так же заметил, что страницы http://schemas.microsoft.com/cdo/config ... /sendusing выдают "The resource you are looking for has been removed, had its name changed, or is temporarily unavailable". Может их нужно заменить?