01. Этот пример (1) позволяет вам отправить электронное сообщение из Access через Outlook. Для работы программы в новых файлах создайте ссылку на Outlook в VBA: C:\Program Files\Microsoft Office\OFFICE11\MSOUTL.OLB
'==============================================================
' Назначение
' "Послать почту из базы данных"
Private Sub butExecute_Click()
Dim app As Outlook.Application 'Приложение программы
Dim dbs As Database 'База данных
Dim rst As Recordset 'Источник email
Dim i As Integer 'Счетчик
Dim itm As MailItem 'Почтовое сообщение
Dim myFile As String 'Присоединяемый файл
On Error GoTo 999
Set dbs = CurrentDb 'Выбор базы данных
Me.Refresh 'Сохраняем данные
myFile = Application.CurrentProject.Path "\" Me.Attachment
myFile = Dir(myFile)
'Открываем таблицу c почтовыми адресами
Set rst = dbs.OpenRecordset("SELECT * FROM [Пример 01email] WHERE ([Вкл]=True);")
If rst.RecordCount 0 Then 'Проверяем записи
rst.MoveLast 'Заполняем запрос
rst.MoveFirst 'Первая запись
Set app = New Outlook.Application 'Новое сообщение
Dim myNamespace, myfolder As MAPIFolder, mynewfolder
Set myNamespace = app.GetNamespace("MAPI")
Set myfolder = myNamespace.GetDefaultFolder(olFolderInbox)
'Set myfolder = _
' app.ActiveExplorer.CurrentFolder.Folders
Set mynewfolder = myfolder.Folders.Add("My Contacts")
Set itm = app.CreateItem(olMailItem) 'Добавляем письмо
itm.Subject = Me.Subject 'Тема письма
itm.Body = Me.Body 'Текст письма
If myFile "" Then itm.Attachments.Add myFile 'Прикрепляем файл
For i = 0 To rst.RecordCount - 1 'Просматриваем адреса
If rst!Вкл = True Then _
itm.Recipients.Add rst!Email 'Добавляем новый адрес
rst.MoveNext 'Следующий адрес
Next
itm.Send 'Отсылаем письмо
app.Quit 'Закрываем Outlook
MsgBox "Письмо успешно отправлено!", vbExclamation, "Почта"
End If
rst.Close 'Закрываем запрос
Exit Sub
999:
MsgBox Err.Description 'Ошибка
Err.Clear
app.Quit
End Sub