Email Loop Error

[Leesha]

Hi,
I've got a form that the user is using to send multiple emails. I've edited the code from previous code that I had gotten here that attached .pdf files. I've deleted to code that attaches the .pdf files. I'm getting an error that says "Loop with do". I'm not sure what I'm missing.
Thanks,
Leesha

Code: Select all

'checks to be sure reason for email is filled out
If IsNull(Me.Comment10) Then
    MsgBox "There must be a description of the reason for the email before the emails can be sent."
    Me.Comment10.SetFocus
    Exit Sub
    End If
If IsNull(Me.Subject) Then
    MsgBox "The subject for the email must be entered before the emails can be sent."
    Me.Subject.SetFocus
    Exit Sub
    End If
 
 
 Dim strWhere As String
    Dim strSQL As String
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim strFilename As String
    Dim outApp As Object
    Dim outMsg As Object
    Dim blnStart As Boolean
    Dim arrNames As Variant
    Dim i As Long


        On Error Resume Next
    ' Try to get running instance of Outlook
    Set outApp = GetObject(Class:="Outlook.Application")
    If outApp Is Nothing Then
        ' If Outlook wasn't running, start it
        Set outApp = CreateObject(Class:="Outlook.Application")
        If outApp Is Nothing Then
            ' We failed to start Outlook, so get out
            MsgBox "We can't start Outlook, sorry!", vbCritical
            Exit Sub
        End If
        ' Set a flag that we started Outlook
        blnStart = True
    End If
    On Error GoTo ErrHandler
    
     ' Create the where-condition
    strWhere = " WHERE EmailFaxSent = False"
    
   
    strSQL = "SELECT ALL * FROM [qryEmailSpreadsheetBulkInsurance]" & strWhere

   Set dbs = CurrentDb
   Set rst = dbs.OpenRecordset(strSQL, dbOpenDynaset)
             
        ' Create a new e-mail message
        Set outMsg = outApp.CreateItem(0) ' olMailItem
        With outMsg
            ' Use the e-mail address field
            'Main Email
            arrNames = Split(rst![FranchiseeEmail], ",")
            For i = 0 To UBound(arrNames)
                .Recipients.Add arrNames(i)
            Next i

            If Not IsNull(rst![Contact5Email]) Then
               arrNames = Split(rst![Contact5Email], ",")
                For i = 0 To UBound(arrNames)
                  ' .Recipients.Add arrNames(i)
                .Recipients.Add(arrNames(i)).Type = 2
                Next i
            End If
            

  
            ' Change the subject as needed
            .Subject = Me.Subject
            .Body = Me.Comment1
            ' Use ONE of the two following lines, not both
            .Send ' to edit the message before sending
        End With

        'Set EmailFaxSent field to True, and EmailDateTimeSent to Now
        rst.Edit
        rst!EmailFaxSent = True
        rst!EmailDateSent = Date
        rst.Update
    
  
             
        rst.MoveNext
        
    Loop

DoCmd.OpenQuery "qryAppendInsuranceEmailBulk"

MsgBox "Emails have been sent"

DoCmd.Close acForm, "frmOutputInsuranceBulkEmail"
    
    
    
  
ExitHandler:
    On Error Resume Next
    rst.Close
    Set rst = Nothing
    Set dbs = Nothing
    If blnStart Then
        outApp.Quit
    End If
    Set outMsg = Nothing
    Set outApp = Nothing
    Exit Sub

ErrHandler:
    If Err = 2501 Then
        Resume Next
    Else
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End If


End Sub

[burrina]

I think you are missing the Do Until or Loop Until statement.

[Leesha]

Thanks! What would that look like, where would it go?

[burrina]

I would do it like this. Untested Air Code. See if it works for you. As always have a backup copy.


Do Until rst.EOF
rst.MoveNext

[HansV]

Here is the code with the missing line added, and indenting made consistent.
Since you didn't post the first line, I made it up myself. You'll have to change it.

Code: Select all

Private Sub cmdSend_Click()
    Dim strWhere As String
    Dim strSQL As String
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim strFilename As String
    Dim outApp As Object
    Dim outMsg As Object
    Dim blnStart As Boolean
    Dim arrNames As Variant
    Dim i As Long

    'checks to be sure reason for email is filled out
    If IsNull(Me.Comment10) Then
        MsgBox "There must be a description of the reason for the email before the emails can be sent."
        Me.Comment10.SetFocus
        Exit Sub
    End If

    If IsNull(Me.Subject) Then
        MsgBox "The subject for the email must be entered before the emails can be sent."
        Me.Subject.SetFocus
        Exit Sub
    End If

    On Error Resume Next
    ' Try to get running instance of Outlook
    Set outApp = GetObject(Class:="Outlook.Application")
    If outApp Is Nothing Then
        ' If Outlook wasn't running, start it
        Set outApp = CreateObject(Class:="Outlook.Application")
        If outApp Is Nothing Then
            ' We failed to start Outlook, so get out
            MsgBox "We can't start Outlook, sorry!", vbCritical
            Exit Sub
        End If
        ' Set a flag that we started Outlook
        blnStart = True
    End If
    On Error GoTo ErrHandler

    ' Create the where-condition
    strWhere = " WHERE EmailFaxSent = False"
    strSQL = "SELECT ALL * FROM [qryEmailSpreadsheetBulkInsurance]" & strWhere

    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset(strSQL, dbOpenDynaset)

    Do While Not rst.EOF
        ' Create a new e-mail message
        Set outMsg = outApp.CreateItem(0) ' olMailItem
        With outMsg
            ' Use the e-mail address field
            'Main Email
            arrNames = Split(rst![FranchiseeEmail], ",")
            For i = 0 To UBound(arrNames)
                .Recipients.Add arrNames(i)
            Next i

            If Not IsNull(rst![Contact5Email]) Then
               arrNames = Split(rst![Contact5Email], ",")
                For i = 0 To UBound(arrNames)
                  ' .Recipients.Add arrNames(i)
                .Recipients.Add(arrNames(i)).Type = 2
                Next i
            End If

            ' Change the subject as needed
            .Subject = Me.Subject
            .Body = Me.Comment1
            .Send ' to send the message immediately
        End With

        'Set EmailFaxSent field to True, and EmailDateTimeSent to Now
        rst.Edit
        rst!EmailFaxSent = True
        rst!EmailDateSent = Date
        rst.Update
        rst.MoveNext
    Loop

    DoCmd.OpenQuery "qryAppendInsuranceEmailBulk"

    MsgBox "Emails have been sent"

    DoCmd.Close acForm, "frmOutputInsuranceBulkEmail"

ExitHandler:
    On Error Resume Next
    rst.Close
    Set rst = Nothing
    Set dbs = Nothing
    If blnStart Then
        outApp.Quit
    End If
    Set outMsg = Nothing
    Set outApp = Nothing
    Exit Sub

ErrHandler:
    If Err = 2501 Then
        Resume Next
    Else
        MsgBox Err.Description, vbExclamation
        Resume ExitHandler
    End If
End Sub

[Leesha]

Thanks Hans! I really appreciate it. Works great!!