Рассылка электронной почты из MS Access

Процедура Email() рассылает письма, параметры которых указаны в записях таблицы eLetters:

Для того, чтобы иметь возможность делать рассылки, Вы должны настроить работу программы blat.exe. Для этого скачайте blat.zip (уникальная копия, между прочим! Я связался с одним из авторов - Tim Charron. Он сжалился надо мной и специально для меня перекомпилил программу, дабы она отсылала письма в кодировке KOI8R) и распакуйте его в любой каталог на Вашем диске. Путь к каталогу, в котором находится программа blat.exe, сделайте значением константы PathToBlat и пропишите в параметре PATH файла autoexec.bat.

Если у Вас связь с Интернет по модему - установите флажок "Подключаться автоматически" в свойствах броузера.

Теперь Вы готовы рассылать письма. Ниже - модуль, позволяющий это осуществлять.

'Данный модуль рассылает письма, выбирая содержание и реквизиты письма из таблицы eLetters
'Основная процедура - Email() Она формирует файл sendmail.bat и при подтверждении пользователя запускает его
'(с) 2001 Максименко Юрий

'Константы, конфигурирующие программу blat.exe
Public Const PathToBlat As String = "C:Blat"
Public Const PathToEmailFile As String = "C:mail"
Public Const ServerName As String = "ИмяПочтовогоСервера"
Public Const UserName As String = "Логин"

'Таблицы кодировок
Public Const S_WIN = "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЬЫЪЭЮЯабвгдеёжзийклмнопрстуфхцчшщьыъэюя"
Public Const S_KOI8R = "бвчздеiцъйклмнопртуфхжигюыэшщяьасБВЧЗДЕЈЦЪЙКЛМНОПРТУФХЖИГЮЫЭШЩЯЬАС"
Public Const S_DOS866 = "ЂЃ‚ѓ„…р†‡?‰Љ‹ЊЌЋЏђ‘’“”•–—�™њ›љќћџ ЎўЈ¤Ґс¦§Ё©Є«¬­®Їабвгдежзиймлкноп"
Public Const S_ISO88595 = "°±ІіґµЎ¶·ё№є»јЅѕїАБВГДЕЖЗИЙМЛКНОПРСТУФХсЦЧШЩЪЫЬЭЮЯабвгдежзиймлкноп"

'Процерура рассылки писем из таблицы. Главная процедура модуля
Sub Email()

Dim rst As DAO.Recordset
Dim n As Long
Dim strToFile, FileName As String

'Убиваем старый командный файлы

On Error Resume Next
  Kill (PathToBlat & "sendmail.bat")
  Kill PathToEmailFile & "Body*.txt"
On Error Goto 0

'Создаем bat-файл
n = FreeFile
FileName = PathToBlat & "sendmail.bat"
n = FreeFile
Open FileName For Output As #n
strToFile = "blat.exe -install " & ServerName & " " & UserName & vbCrLf
Print #n, , strToFile

Set rst = CurrentDb.OpenRecordset("SELECT eLetterID FROM eLetters")
If Not rst.EOF Then

rst.MoveLast
rst.MoveFirst

End If
Do While Not rst.EOF

strToFile = StringForBat(rst!eLetterID) 'Строка для одного письма
Print #n, , strToFile
rst.MoveNext

Loop
rst.Close

Close #n

If MsgBox("bat-файл для отсылки писем создан. Толкнуть его на выполнение?", vbQuestion + vbYesNo + vbDefaultButton2, "А это кому-нибудь нужно?") = vbYes Then Call Shell(FileName, vbHide)

Function StringForBat(ByVal eLetterID As Long) As String

'Создается командный файл и запускается
Dim Recipient, Subject, body, CopyTO, AttachedFileName, FileName, strToFile As String
Dim rst As DAO.Recordset
Dim n As Long

'Выясним параметры письма
Set rst = CurrentDb.OpenRecordset("SELECT * FROM eLetters WHERE eLetterID=" & eLetterID)
Recipient = rst!Recipient
CopyTO = rst!CopyTO
Subject = rst!Subject
body = CODE_TO_CODE(rst!body)
AttachedFileName = rst!AttachedFileName
rst.Close

'Создаем txt-файл для тела сообщения
n = FreeFile
FileName=PathToEmailFile & "Body" & EletterID & ".txt"

Open FileName For Output As #n
Print #n, Spc(0), Trim(body)
Close #n

StringForBat = "blat.exe " & chr(34) & FileName & chr(34) & " -t " & Recipient
If Not (CopyTO = "") Then StringForBat = StringForBat & " -c " & CopyTO
If Not (Subject = "") Then

Subject = CODE_TO_CODE(Subject)
StringForBat = StringForBat & " -s " & Chr(34) & CODE_TO_CODE(Subject, , S_DOS866) & Chr(34)

End If

If Not (AttachedFileName = "") Then StringForBat = StringForBat & " -attach " & chr(34) & AttachedFileName & chr(34)
StringForBat = StringForBat & " -mime"

End Function

'функция перекодировки
'(c) Владимир Лаврушкин
Public Function CODE_TO_CODE(ByVal Ustr As String, Optional S_Input = S_WIN, Optional S_OutPut = S_KOI8R) As String

Dim i, k As Integer

CODE_TO_CODE = ""

For i = 1 To Len(Ustr)

k = InStr(1, S_Input, Mid(Ustr, i, 1), vbBinaryCompare)
If k > 0 Then
     CODE_TO_CODE = CODE_TO_CODE & Mid(S_OutPut, k, 1)
Else
     CODE_TO_CODE = CODE_TO_CODE & Mid(Ustr, i, 1)
End If

Next i