Private Sub SendEmailsX_Click()
On Local Error GoTo SendEmailsX_Error
Dim olApp As Object
Dim olMail As Object
Dim rs As DAO.Recordset
Dim EmailList As String
Dim Subj As String
Dim Bdy As String
Dim LngCount As Long
Dim lngRSCount As Long
Dim lngRecordPosition As Long
Subj = "Your appointment today"
Bdy = "Hi, we're going to be at your home"
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
Set rs = CurrentDb.OpenRecordset("Temp Daily Table Query for Form Test")
lngRSCount = rs.RecordCount
MsgBox ("0-The number of records in the table is: " & lngRSCount)
If Not rs.EOF Then
rs.MoveLast ' Move to the last record
rs.MoveFirst ' Move back to the first record
End If
While Not rs.EOF
MsgBox ("1- Am I at the EOF? " & rs.EOF)
MsgBox ("2-The record number is: " & lngRecordPosition)
olMail.To = rs!EmailX
olMail.Subject = Subj & " " & lngRecordPosition
' olMail.BodyFormat = olFormatHTML
' olMail.HTMLBody = Bdy
olMail.Body = Bdy
' olMail.Display
' olMail.Save
olMail.Send
' rs.Edit
' rs.Update
' rs.Close
MsgBox ("3-The record number is: " & lngRecordPosition)
If Not rs.EOF Then
MsgBox ("4- Am I at the EOF? " & rs.EOF)
rs.MoveNext
End If
MsgBox ("5-The record number is: " & lngRecordPosition)
Wend
' Loop
' End If
olApp.Quit
SendEmailsX_Resume:
Exit Sub
SendEmailsX_Error:
MsgBox "Sprinkle, the Error (" & CStr(Err.Number) & ") " & Err.Description, _
vbExclamation, "Error!"
Resume SendEmailsX_Resume
End Sub