On Error GoTo err Dim OutApp As Outlook.Application Dim OutMail As Outlook.MailItem Dim strBody As String Dim db As Database Dim rs As Recordset Dim emailcount As Long emailcount = 0 Set OutApp = CreateObject("Outlook.Application") Set db = CurrentDb Select Case Me.EMAILTYPE Case "Annual Training" Set rs = Forms!frmAnnualTraining.Form.RecordsetClone End Select If rs.RecordCount = 0 Then MsgBox "There are no reminders to create!", vbCritical, "Reminders" Set rs = Nothing Exit Sub End If rs.MoveFirst Do Until rs.EOF If Not IsNull(rs![EMPEMAIL]) And IsNull(rs![AETDATE]) Then Set OutMail = OutApp.CreateItem(0) With OutMail .To = rs![EMPEMAIL] .CC = "" .BCC = "" .Subject = Me.EMAILSUBJECT .HTMLBody = Me.EMAILDESC .Save emailcount = emailcount + 1 End With End If rs.MoveNext Loop If emailcount = 0 Then MsgBox "There are no employees without an Annual Training date for the calendar year." Else MsgBox "Created Alerts. Please review them and send." DoCmd.Close acForm, "frmReminders" Exit Sub err: MsgBox "Unable to create emails at this time. If problem persists, contact system administrator." MsgBox err.Description Exit Sub End Sub
From novice to tech pro — start learning today.