Sub SMTP()
Dim oMSG As Object
Dim oConfig As Object
Dim CFields As Object
Dim strBody As String
Dim MailUser As String

Dim rst As ADODB.Recordset
Set rst = New ADODB.Recordset


'создаем объект Message это наше письмо
Set oMSG = CreateObject("CDO.Message")
'создаем объект Configuration это настройки соединения
Set oConfig = CreateObject("CDO.Configuration")
Set CFields = oConfig.Fields
Set oMSG.Configuration = oConfig
CFields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
CFields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mskgate1" 'адрес SMTP сервера
CFields("http://schemas.microsoft.com/cdo/configuration/sendusername") = "SUPPORT@mechel.com" 'Login
CFields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "" 'пароль
CFields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
CFields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
CFields("urn:schemas:mailheader:content-language") = "windows-1251"
CFields.Update

lngIDSoglasDoc = Me.ID_Soglas_Doc

           strSQL = "SELECT tsSotrudnik.Mail" _
                & " FROM Soglas_User_tbl INNER JOIN tsSotrudnik ON Soglas_User_tbl.Sotrudnik = tsSotrudnik.Sotrudnik" _
                & " WHERE Soglas_User_tbl.ID_Soglas_Doc=" & lngIDSoglasDoc & " AND Soglas_User_tbl.NumSoglasovanie=1;"
                rst.Open strSQL, CurrentProject.Connection, adLockOptimistic

If rst.RecordCount <> 0 Then

Do Until rst.EOF
rst.MoveFirst 'Переходим на первую запись набора

MailUser = rst![Mail]

oMSG.To = MailUser 'адрес получателя
oMSG.From = "osmor <@mail.ru>" 'адрес отправителя
oMSG.subject = "Тема" ' тема письма
oMSG.BodyPart.Charset = "windows-1251" ' кодировака письма
'oMSG.AddAttachment "c:VANotesInstaller.log" 'путь к вложенному файлу
'формируем HTML текст который будет телом письма
strBody = "Здесь HTML текст." & _
"C уважением,"
oMSG.HTMLbody = strBody 'тело письма
oMSG.send 'отправляем

rst.MoveNext 'Переходим на следующюю запись набора
Loop
Else
MsgBox "Нет адресов для отправки"
End If
rst.Close

'обнуляем переменные
Set CFields = Nothing
Set oConfig = Nothing
Set oMSG = Nothing
End Sub