Данный скрипт можно использовать для массовой рассылки писем по нескольким адресам | Код |
'Скрипт, осуществляющий массовую рассылку электронной почты
'Список рассылки берётся из текстового файла email.txt
'Текст письма берётся из файла text.htm
'Пишется лог событий в файл mailer.log
Option Explicit
Const ForAppending = 8
Dim HTMLBody
Dim Emails
Dim I
AppendToFile ".\mailer.log", "Start at " & CStr(Now)
If MyFileExist ("text.htm") Then
AppendToFile ".\mailer.log", "Считываем текст письма."
HTMLBody = TextFromFile ("text.htm")
Else
AppendToFile ".\mailer.log", "Файла с текстом письма не обнаружено!" & vbCrLf & "Finish at " & CStr(Now)
End If
If MyFileExist ("email.txt") Then
AppendToFile ".\mailer.log", "Считываем e-mail адреса."
Emails = Split (TextFromFile ("email.txt"), vbCrLf)
Else
AppendToFile ".\mailer.log", "Файла с адресами не обнаружено!" & vbCrLf & "Finish at " & CStr(Now)
End If
AppendToFile ".\mailer.log", "Начинаем отправку писем."
For I = 0 To UBound (Emails) - 1
AppendToFile ".\mailer.log", "Письмо №-" & (I + 1) & " для '" & Emails(I) & "'"
AppendToFile ".\mailer.log", "Результат отправки: " & SendEMail ("[email protected]", "login", "password", "smtp.provider.ru", Emails(I), HTMLBody)
Next
AppendToFile ".\mailer.log", "Finish at " & CStr(Now) & vbCrLf
WScript.Quit
'********************************************************************
'*
'* Функция : SendEMail
'* Описание : Функция отправляет письмо по указанному адресу
'* Вход :
'* strFrom - e-mail отправителя
'* strLogin - логин на smtp-сервер
'* strPass - пароль на smtp-сервер
'* SMTPServer - smtp-сервер
'* strTo - e-mail адресата
'* strTextbody - текст письма
'* Выход : 0 - ошибок при отправке не произошло
'* номер ошибки + расшифровка при ошибке отправки
'*
'********************************************************************
Function SendEMail ( byval strFrom, byval strLogin, byval strPass, byval SMTPServer, byval strTo, byval strTextbody)
Dim intSMTPPort, bSMTPUseSSL, intUseAuth, objEmail
intSMTPPort = 25 ' Порт SMTP Сервера
bSMTPUseSSL = False ' При соединении с SMTP через SSL, необходимо изменить значение на True
intUseAuth = 1 ' Если SMTP-аутентификация не требуется, можно установить значение 0. Для NTLM аутентификации - значение 2
On Error Resume Next
Err.Clear
Set objEmail = CreateObject("CDO.Message")
objEmail.From = strFrom
objEmail.To = strTo
objEmail.Subject = "Robot's report."
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPServer
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = intUseAuth
objEMail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = bSMTPUseSSL
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = intSMTPPort
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusername") = strLogin
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strPass
objEmail.HTMLBody = strTextbody
objEmail.Configuration.Fields.Update
objEmail.Send
Set objEmail = Nothing
If Err.Number Then
SendEMail = Err.Number & " - " & Err.Description
Else
SendEMail = 0
End If
On Error Goto 0
End Function
'********************************************************************
'*
'* Процедура : AppendToFile
'* Описание : Дописывает в файл текстовую информацию
'* Вход : strFileName - имя файла, в который нужно дописать информацию
'* strString - дописываемая информация
'*
'********************************************************************
Sub AppendToFile(ByVal strFileName, ByVal strString)
Dim fso, f
Err.Clear
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(strFileName, ForAppending, True)
f.WriteLine strString
f.Close
Set f = Nothing
Set fso = Nothing
End Sub
'********************************************************************
'*
'* Функция : MyFileExist
'* Описание : Функция проверки существования файла
'* Вход : Имя файла
'* Выход : true, если файл существует, и false, если файл отсутствует.
'*
'********************************************************************
Function MyFileExist (ByVal FileName)
dim fso
Err.Clear
On Error Resume Next
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
MyFileExist = (fso.FileExists(FileName))
Set fso = Nothing
end Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'#
'# Процедура TextFromFile
'# Описание: Возвращает текст из текстового файла
'# Вход : полное имя к текстовому файлу
'# Выход : нет
'#
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function TextFromFile (byval strFileName)
Const ForReading = 1
Dim objFSO, objTextFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile ( strFileName, ForReading)
TextFromFile = objTextFile.ReadAll
Set objTextFile = Nothing
Set objFSO = Nothing
End Function
|
Подробней тут - http://wiki.mihanik.net/index.php/%D0%9C%D...%81%D0%B5%D0%BC --------------------
Программистами не рождаются, - это родовая травма...   |
Массовая рассылка писем 
Загрузка ...
