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