Просьба помочь найти ошибку в коде (цикл)

Вторник, 20 Октября 2015 г. 10:14 + в цитатник

День добрый.
Необходимо отправить почту отобранным в запросе получателям. Что-то в цикле не то, отправляет по кругу без остановки. Просьба помочь. Спасибо.

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