Hi All, I am trying to get my Database to send an email with and attachment, I have that part working. It it the Loop that I am having an issue with. I have the code to look at a folder and attache the correct attachment but my code does not go to the next record. I have the code looking at form that I made, the form uses a Query to pull the correct records.... Please help it sends the email to only the person that I am looking at on the Form and it sends about 10 emails to that person only, and does not move to the next record.
Code:
Private Sub EmailSend_Click()
Dim DB As DAO.Database
Dim RS As DAO.Recordset
Dim strSQL As String
Set DB = CurrentDb
strSQL = "select ..."
Set RS = DB.OpenRecordset("Email")
Do Until RS.EOF
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim DWRFile As String
DWRFile = [psw/sid] & ".pdf"
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(Me.Email)
objOutlookRecip.Type = olTo
' Set the Subject, Body, and Importance of the message.
.Subject = "This is a test"
.Body = "Good Afternoon " & [Contact] & "," & Chr(10) & Chr(10) & "Please see the attached Drinking Water report that was generated on " & Format(Now(), "short date") & "." & Chr(10) & Chr(10) & "Thank You," & Chr(10) & "DSHS Laboratory" & Chr(10) & "Environmental Sciences Branch" & Chr(10) & "100 W.49th St." & Chr(10) & "Austin, Tx 78756" & Chr(10) & "512-776-7587"
' Add attachments to the message.
If Not IsMissing(AttachmentPath) Then
On Error Resume Next
Set objOutlookAttach = .Attachments.Add("C:\Users\mmessmer828\Desktop\Emailed Reports\Alot\" & DWRFile)
.Send
RS.MoveNext
End If
' Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
End With
RS.MoveNext
Loop
RS.Close
Set RS = Nothing
Set DB = Nothing
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
MsgBox "Emails Sent"
End Sub