X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
   Reply to this topicStart new topic
> Loops Through And Sends The Same Email Multiple Times    
post Dec 9 2015, 07:36 PM

Posts: 51
Joined: 3-December 10
From: San Diego, CA

Have a new challenge. I have created a database which will create a table and then send notificaitons to leaders, including a list of their employees. There is an issue that it loops through multiple times for each supervisor name. For instance, Supervisor 1 has three records, so it will loop through the table three times, sending three emails. Each email is correct; it just sends multiple times. I only need it to send one email with one listing. If Supervisor 2, have 4 records, loops through 4 times and send 4 emails.

I have a feeling that it has to do with my recordset or how I set up my table. Can you check my coding and the attached database? Any ideas?

Looking forward to anyone's assistance - Lauren

OVERVIEW: The database will create a table which lists all the employees with a past due evaluation along with the supervisor name.

Here is my coding objective:
1. Loop through the contents of the table
2. Identify a supervisor name along with the employees that report to that specific supervisor
3. Those records for this supervisor drop into a report, which becomes the email body
4. An email is sent to this supervisor with ONLY their employees listed
5. Program loops through the records for the next supervisor and their employees
6. Continues to loop until it reaches the end of the list

Option Compare Database

'Objective of this function is to send a listing to each supervisor of just their employees who appear on the list.
'The code should loop through the list, sending just those employees that have the supervisor's email.
'Once the code has sent all the records in the file, the code should stop and a message box appearing, stating the process is completjed.

Public Function send_PerfEvalPastDue()

Dim sSql As String
Dim rs As DAO.Recordset

Set OutApp = CreateObject("Outlook.Application")
Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblPastDue WHERE SupvName;") 'creating my record set - only pulling the records that have a common supervisor

With rs
    If .EOF And .BOF Then 'If there are no records, then a message should appear
        MsgBox "No records on your table"
    Else 'asking the program to loop through all of the records
        Do Until .EOF
            'Outputs the data for the specific supervisor called out in the recordset
            'Clears out the temporary table
                sSql = "DELETE FROM tblPastDueTemp;"
                DoCmd.SetWarnings False
                DoCmd.RunSQL sSql
                DoCmd.SetWarnings True
            'Pulls the data from the table and places it into the temporary table
                sSql = "INSERT INTO tblPastDueTemp ( CC, DeptName, SupvName, [EE ID], [EE Name], [Lawson Due Date], [Grace Period Due Date], Comment, SupvEmail ) " _
                       & "SELECT tblPastDue.CC, tblPastDue.DeptName, tblPastDue.SupvName, tblPastDue.[EE ID], tblPastDue.[EE Name], tblPastDue.[Lawson Due Date], tblPastDue.[Grace Period Due Date], tblPastDue.Comment, tblPastDue.SupvEmail " _
                       & "FROM tblPastDue " _
                       & "WHERE (tblPastDue.SupvName) = '" & rs!SupvName & "'"
                DoCmd.SetWarnings False
                DoCmd.RunSQL sSql
                DoCmd.SetWarnings True
            'Outputs the report that will be used for the email message/body
                DoCmd.OutputTo acOutputReport, "tblPerfEvalPastDue", "HTML(*.html)", "C:\temp\EmailPastDueEvals" & ".html"
            'Going to open Outlook, create then send the email.
                SendMail ' public function
    Set rs = Nothing
    End If
End With

End Function

Public Sub SendMail()

'   Dim olApp As Object
'   Dim objMail As Object
Dim olApp As Outlook.Application
Dim objmail As Outlook.MailItem

Dim rst As DAO.Recordset
Dim Receiver As String
'Creates a text stream
                Set oFilesys = CreateObject("Scripting.FileSystemObject")
                Set oTxtStream = oFilesys.OpenTextFile("C:\temp\EmailPastDueEvals" & ".html", 1)
                txtHTML = oTxtStream.ReadAll

Set rst = CurrentDb.OpenRecordset("tblPastDueTemp")

'Checking to see if Outlook is open and need to create an instance to actually send e-mail

   On Error Resume Next 'Keep going if there is an error
   Set olApp = GetObject(, "Outlook.Application") 'See if Outlook is open

    If Err Then 'Outlook is not open
       Set olApp = CreateObject("Outlook.Application") 'Create a new instance
    End If
'Creating e-mail item
'  Set objmail = olApp.CreateItem(olMailItem)
Set objmail = olApp.CreateItem(olMailItem)

    Receiver = rst!SupvEmail
   With objmail
'Set body format to HTML
     .BodyFormat = olFormatHTML
     .To = Receiver
     .Cc = ""
     .Subject = "TEST - You can delete!  Past Due Perf Eval Message"
     .HTMLBody = txtHTML

End With

End Sub

Public Function CleanUp()
'Cleaning up the system when everything has been sent.

    Kill "c:\temp\EmailPastDueEvals" & ".html"

    Set olApp = Nothing
    Set objmail = Nothing

    Set oTxtStream = Nothing
    Set oFilesys = Nothing

'Users will know the email was sent.
  MsgBox "Operation completed successfully"

End Function

Attached File(s)
Attached File  PerfEvalOverdue1.zip ( 102.08K )Number of downloads: 10
Go to the top of the page
post Dec 9 2015, 07:52 PM

Posts: 2,428
Joined: 12-February 15
From: SW AZ

Look at post #3 of you original topic. Using those methods
  • Your base record set would just list supervisors
  • For each supervisor you'd send an email using the SendObject method, after setting the saved query's filter property to the current supervisor.
Go to the top of the page
post Dec 9 2015, 09:17 PM

Posts: 2,428
Joined: 12-February 15
From: SW AZ

Ok, I've done most of the work. You'd replace your send_PerfEvalPastDue function with the following procedure.
'  SendSupvEmail
'     procedure sends past due performance evaluation lists to each supervisor
Public Sub SendSupvEmail()
   Dim rs As DAO.Recordset
   Dim sql As String
   sql = "SELECT DISTINCT SupvName, SupvEmail FROM tblPastDue;"
   'create recordset of Supervisors
   Set rs = CurrentDb.OpenRecordset(sql)
   With rs
      If .BOF Then
         'no supervisor records
         MsgBox "No supervisor records for emailing.", vbInformation
         'supervisor records found, send emails
            'set the rptPerfEvalPastDue report's RecordSource query's Filter Property to this supervisor
            SetQueryProperty "qryPerfEvalPastDue", "Filter", "SupvName=""" & !SupvName & """"
            'set the FilterOnLoad property
            SetQueryProperty "qryPerfEvalPastDue", "FilterOnLoad", True
            'create and send the email
            DoCmd.SendObject acSendReport, "TblPerfEvalPastDue", acFormatPDF, !SupvEmail, , , _
               "Past Due Perf Eval Message", "Your past due performance evaluation list is attached."
         Loop Until .EOF
      End If
   End With
   Set rs = Nothing
End Sub

qryPerfEvalPastDue has the following sql
SELECT CC, DeptName, SupvName, [EE ID], [EE Name], [Lawson Due Date], [Grace Period Due Date], Comment
FROM tblPastDue WHERE [SupvName] = 'Joe';
Note the where clause is changed for each supervisor. This query replaces the recordsource for the TblPerfEvalPastDue report.

The SetQueryProperty is
'after LPurvis in
Sub SetQueryProperty(strQueryName As String, strPropertyName As String, varPropVal)
On Error Resume Next
    Dim db As Database
    Dim qdf As QueryDef
    Dim prp As DAO.Property
    Set db = CurrentDb
    Set qdf = db.QueryDefs(strQueryName)
    With qdf
        Set prp = qdf.Properties(strPropertyName)
        If Err Then
            Set prp = .CreateProperty(strPropertyName, dbText, varPropVal)
            .Properties.Append prp
        End If         'Else
            prp.Value = varPropVal
'        End If
    End With
    Set prp = Nothing
    Set qdf = Nothing
    Set db = Nothing
End Sub
Go to the top of the page
post Dec 14 2015, 07:56 PM

Posts: 51
Joined: 3-December 10
From: San Diego, CA

John -

Thank you so much for everything. You really did the heavy lifting for me on this one, saving me so much time. I'm trying to learn VBA as I go, which can be very challenging when faced with a deadline.

You really saved my weekend from endless googling and debugging. Thanks again -

Go to the top of the page

Custom Search
RSSSearch   Top   Lo-Fi    13th December 2017 - 05:24 PM