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.
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