Private Sub Otpravit_Click()
On Error GoTo Err_Otpravit_Click
' Отправка писем
Dim prog As Outlook.Application  ' Объект - программаOutlook
Dim baza As Database ' Объект - база данных
Dim tablica As Recordset ' Таблица ТаблицаПисьма
Dim i As Integer ' Счетчик цикла
Dim portion As Integer ' Счетчик порций
Dim zapis As Integer ' Номер записи
Dim pismo As MailItem ' Объект - почтовое сообщение
Dim dopfail As String ' Присоединяемый файл
Dim Copies As Integer ' Число копий письма
Dim pauza As Integer ' Величина интервала ожидания
Dim PauseTime, Start ' Переменные для таймера
Dim Konec As Boolean ' Конец таблицы
Dim myNamespace As Outlook.NameSpace
' Создание объектов для письма
Set prog = New Outlook.Application
Set myNamespace = prog.GetNamespace("MAPI")
' Начальные значения переменных
dopfile = \" \"
If Len(Trim(Me!Text9)) > 0 Then dopfail = Me!Text9
dopfile = Trim(dopfile)
pauza = Me!Interval
Konec = False
If pauza < 0 Then pauza = 1
Copies = Me!Kopii
If Copies < 0 Then Copies = 1
' Подключение таблицы
Set baza = CurrentDb ' Работаем с этой же БД
Set tablica = baza.OpenRecordset(\"SELECT * FROM [ТаблицаАдреса] WHERE ([Да]=True);\")
' Основной цикл
 Do While Me!Check34 And Not Konec
 Me.Refresh  ' Пересчет данных формы
   If tablica.RecordCount <> 0 Then ' Таблица не должна быть пустой
   tablica.MoveLast ' Последняя запись
   tablica.MoveFirst ' Первая запись
   zapis = 1
   ' Ищем новые записи
     Do While tablica!flag = 1 And zapis < tablica.RecordCount
     tablica.MoveNext ' Выбор следующей записи
     zapis = zapis + 1
     Loop
     If tablica.RecordCount - zapis >= Copies Then  ' Определение количества адресов
     portion = Copies
     Else
     portion = tablica.RecordCount - zapis + 1
     End If
     ' Формирование письма в формате Outlook
   Set pismo = prog.CreateItem(olMailItem) ' Создание объекта
   pismo.Subject = Me!Tema ' Тема сообщения
   pismo.Body = Me!Tekst ' Текст сообщения
   If dopfail <> \"\" Then pismo.Attachments.Add dopfail ' Дополнительный файл
       For i = 1 To portion ' Перебор очередной порции адресов
       If tablica!Да And Not Konec Then
         If tablica!flag <> 1 Then
         pismo.Recipients.Add tablica!Email ' Еще один адрес
         tablica.Edit
         tablica!flag = 1 ' Адрес использован
         tablica.Update
         End If
       End If
       If zapis < tablica.RecordCount Then
       tablica.MoveNext ' Выбор следующего адреса
       zapis = zapis + 1
       Else
       Konec = True
       End If
     Next
   Me!Obrab = zapis  ' Индикация номера записи в форме
  ' pismo.Display ' Показ письма в окне. Для отладки
   pismo.Send ' Отправка письма
   Me!Поле93 = "РАССЫЛКА"
   Me!Поле93.BackColor = RGB(0, 250, 0)
   End If
 ' Интервал ожидания
 PauseTime = pauza ' Установка величины паузы
 Start = Timer    ' Текущее значение таймера
   Do While Timer < Start + PauseTime And Me!Check34 ' Цикл ожидания
   DoEvents    ' Позволяется работать другим процессам
   Loop
 Loop
Me!Поле93 = \"ОСТАНОВ\"
Me!Поле93.BackColor = RGB(200, 200, 200)
tablica.Close ' Закрытие таблицы
' Обработка ошибки
Exit_Otpravit_Click:
prog.Quit
Exit Sub
Err_Otpravit_Click:
MsgBox Err.Description ' Сообщение об ошибке
Resume Exit_Otpravit_Click
End Sub