Автоматическая отправка e-mail с Excel или с Access

Public Type Customerlnfo 'пользовательский тип данных для формирования данных о Дне рождения
 
 Name As String * 20
 EmAdr As String * 20
 Txt As String * 15
 BerthDay As Date
 
 End Type
 
Public Const UserKolvo As Integer = 3 'Количество лиц внесённых в Вашу базу
'Вариант получения данных может быть любой хранение на листе Excel
'в базе данных Access в текстовом файле итд
'
 
 Sub AutoPozdrav()
 
Dim i As Integer
Dim PozdrFlag As Boolean
 
Dim UserInfo(UserKolvo) As Customerlnfo 'определям переменную и задаём данные
 
 
UserInfo(1).Name = "Иван Петрович"
UserInfo(1).EmAdr = "IP@mail.ru"
UserInfo(1).BerthDay = #10/1/1962#
UserInfo(1).Txt = "Уважаемый "
 
UserInfo(2).Name = "Максим"
UserInfo(2).EmAdr = "Maks@mail.ru"
UserInfo(2).BerthDay = #3/8/1978#
UserInfo(2).Txt = "Дорогой"
 
UserInfo(3).Name = "Таня"
UserInfo(3).EmAdr = "dmalexeev@mail.ru"
UserInfo(3).BerthDay = #11/6/1982#
UserInfo(3).Txt = "Милая"
 
PozdrFlag = False 'флаг чтоб знать что кого то поздравили
 
'перебираем в цикле всех лиц из базы
'и сравниваем день и месяц их рождения с днём и месяцем текущей даты
For i = 1 To UserKolvo
If Day(UserInfo(i).BerthDay) = Day(Date) And Month(UserInfo(i).BerthDay) = Month(Date) Then '
Call Otpravka(UserInfo(i).Name, UserInfo(i).EmAdr, UserInfo(i).Txt)
PozdrFlag = True
End If
Next i
 
If PozdrFlag = False Then
MsgBox "Сегодня поздравлять некого"
End If
 
End Sub
 
'наиболее простой быстрый вариант отправки сообщений использование библиотеки CDO
'
'
 
 Function Otpravka(Name As String, Adr As String, Text As String)
 
Dim MSG As Object
Dim Config As Object
Dim CFields As Object
Dim strBody As String
'создаем объект Message это наше письмо
Set MSG = CreateObject("CDO.Message")
'создаем объект Configuration это настройки соединения
Set Config = CreateObject("CDO.Configuration")
Set CFields = Config.Fields
Set MSG.Configuration = Config
CFields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
CFields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.mail.ru" 'адрес SMTP сервера
CFields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
CFields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Ваш@mail.ru" 'Login
CFields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "********" 'пароль
CFields("urn:schemas:mailheader:content-language") = "windows-1251"' кодировка письма чтобы писать по русски
CFields.Update
MSG.To = Adr 'адрес получателя
MSG.From = "Ваш@mail.ru" 'адрес отправителя
MSG.Subject = "С днём Рожденья" + Name ' тема письма
 
 
MSG.BodyPart.Charset = "windows-1251" ' кодировка письма чтобы писать по русски
'формируем текст который будет телом письма
strBody = Text + vbNewLine & _
Name + vbNewLine & _
" Поздравляю с Днём рождения" + vbNewLine & _
"Желаю счастья в личной жизни " & _
"Пух"
 
 
MSG.HTMLBody = strBody 'тело письма
MSG.Send 'отправляем
'обнуляем переменные
Set CFields = Nothing
Set Config = Nothing
Set MSG = Nothing
 
 
End Function