ник: k@s
Почему файл не прикрепляется.Ни че понять не могу.
Dim rst As ADODB.Recordset
Dim strSQL As String
Dim strWorkName As String
Set rst = New ADODB.Recordset
strSQL = "select * from qry_WorkSendSel"
rst.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
Select Case MsgBox("Письмо будет разослано " & rst.RecordCount & " адресатам." _
& vbCrLf & "Разослать?" _
& vbCrLf & "" _
, vbYesNo Or vbQuestion Or vbDefaultButton1, "Рассылка писем")
Case vbYes
Case vbNo
rst.Close
Set rst = Nothing
Exit Sub
End Select
If rst.RecordCount = 0 Then
rst.Close
Set rst = Nothing
Exit Sub
End If
'создает новое письмо с вложением для нескольких адресатов
Dim OL_App As Outlook.Application
Dim OL_ItemMail As Outlook.MailItem
Dim OL_NameSpace As Outlook.NameSpace
Dim RecipientTask As Recipient
Dim OL_Pattern As Outlook.RecurrencePattern
Dim OL_FolderMail As Outlook.MAPIFolder
Set OL_App = CreateObject("Outlook.Application") ' получаем объект Outlook
Set OL_NameSpace = OL_App.GetNamespace("MAPI")
' получаем ссылку на папку черновики
Set OL_FolderMail = OL_NameSpace.GetDefaultFolder(olFolderDrafts)
SysCmd acSysCmdClearStatus ' очищаем статусную строку
' цикл формирования писем
Do While Not rst.EOF
Set OL_ItemMail = OL_App.CreateItem(olMailItem) ' создаем новое письмо
With OL_ItemMail
.To = Trim(rst.Fields("WorkName")) & " <" & Trim(rst.Fields("EMail")) & ">" 'адрес получателя
' .CC = "test@mail.com" 'копия
.Subject = Nz(Me.fldTo, "") & " за " & CStr(Date) ' заголовок письма
.Body = Nz(Me.fldSend, "")
' установка вложений. Если файл не существует, то будет ошибка
Select Case intPril
Case 1
.AddAttachment.Add ("c:\ди.txt")
Case 2
.AddAttachment.Add ("c:\ди.txt")
.AddAttachment .Add("c:\ки.txt")
End Select
If Me.fSl1 Then ' проверка необходимости установить уведомление о доставке
.OriginatorDeliveryReportRequested = True 'Уведомление о доставке
End If
If Me.fSl2 Then ' проверка необходимости установить уведомление о прочтении
.ReadReceiptRequested = True 'Уведомление о прочтении
End If
.Save ' сохраним письмо
If Not Me.NoSend Then ' проверка необходимости отправлять письмо
If Me.fSec Then ' проверка необходимости выставлять задержку перед отправлением
Sleep vSec * 1000 'ecnfyjdbv задержку в vSec
End If
.Send ' отправим письмо
End If
' отображение инфы о сформированном письме в Status Bar
SysCmd acSysCmdSetStatus, "Формирование письма для - " & Trim(rst.Fields("WorkName"))
rst.MoveNext
End With
Set OL_ItemMail = Nothing ' освобождаем переменную
Loop
rst.Close
Set rst = Nothing
Set OL_App = Nothing
Call MsgBox("Письма разосланы.", vbInformation, "Программа рассылки писем")
SysCmd acSysCmdSetStatus, "Готово"
'DoCmd.Close acForm, Me.Name
On Error GoTo 0
Exit_btnSend_Click:
Exit Sub
btnSend_Click_Error:
MsgBox "Ошибка " & Err.Number & " (" & Err.Description & ") в процедуре btnSend_Click в VBA Document Form_frm_Letter"
Resume Exit_btnSend_Click