'==============================================================
'  Назначение
'    "Послать почту из базы данных"
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