I’m stumped on this one. I have an action item list on a fairly large Project Management DB. This list is datasheet that is embedded as a subform on a PopUp form from the Main Menu. On the Action Item table I have a [email] field that is used as a checkbox on the form. The user can then create an action item check the box and I have a cmd button for “Send Selected Records”. (The code for this button is below). An email is created with the action item(s) embedded into an email as an HTML table with the assigned to person in the To line. I hope this makes sense. The email pulls from qrySendActionItems looking for the tasks with -1.
It works great… for some records. When building the HTML table of the selected it loops through qrySendActionItems. However it is NOT accurate. For example, I can select ten records it will only embed the first two. I can select another 10 and it will embed the first 8. Other times it works fine. It seems completely random of which records will be embedded and which will no work. Weird part, I can select a records that were missed and they will embed if they are the only by themselves. Something is breaking the Loop and as I said, it has me stumped. I believe the problem is around the 'Create each body row’ area.
I have verified the query is working and pulls selected records. The qry is cleared as designed each time. The emails address of ALL selected records populate correctly.
Everything works except the Loop to create the HTML table.
The really frustrating part… I know this code works because the exact same procedure sends out other lists just fine. It’s only the Action Items. I appreciate the help, Stack Overflow is awesome.
Private Sub cmdEmailAI_Click() If Me.Dirty Then DoCmd.Save End If Dim olApp As Object Dim olTask As Object Dim olItem As Variant Dim db As DAO.Database Dim rec As DAO.Recordset Dim strQry As String Dim aHead(1 To 10) As String Dim aRow(1 To 10) As String Dim aBody() As String Dim lCnt As Long 'Create the header row aHead(1) = "ID" aHead(2) = "Project Name" aHead(3) = "Status" aHead(4) = "Start Date" aHead(5) = "Due Date" aHead(6) = "Finish Date" aHead(7) = "ECD" aHead(8) = "Assigned To" aHead(9) = "Deliverable" aHead(10) = "Comments" lCnt = 1 ReDim aBody(1 To lCnt) 'Define aBody(lCnt) = "<HTML><body><table border='2'><tr style= 'background-color:Yellow;color:Black;text-align:center;Font Face:Veranda;'><th>" & Join(aHead, "</th><th>") & "</th></tr>" 'Create each body row strQry = "SELECT * From qrySendActionItems" Set db = CurrentDb Set rec = CurrentDb.OpenRecordset(strQry) If Not (rec.BOF And rec.EOF) Then Do While Not rec.EOF lCnt = lCnt + 1 ReDim Preserve aBody(1 To lCnt) aRow(1) = rec("ID") aRow(2) = rec("ProjectName") aRow(3) = rec("Status") aRow(4) = Nz(rec("StartDate"), "") aRow(5) = Nz(rec("DueDate"), "") aRow(6) = Nz(rec("FinishDate"), "") aRow(7) = Nz(rec("ECD"), "") aRow(8) = Nz(rec("AssignedTo"), "") aRow(9) = Nz(rec("Deliverable"), "") aRow(10) = Nz(rec("Comment"), "") aBody(lCnt) = "<tr style='color:grey;text-align:Left'><td>" & Join(aRow, "</td><td>") & "</td></tr>" rec.MoveNext Loop End If aBody(lCnt) = aBody(lCnt) & "</table></body></html>" 'create the email Set olApp = CreateObject("Outlook.application") Set olItem = olApp.CreateItem(0) Set MyDB = CurrentDb Set rst = MyDB.OpenRecordset("qrySendActionItems", dbOpenSnapshot, dbOpenForwardOnly) Set oLook = CreateObject("Outlook.Application") Set olns = oLook.GetNamespace("MAPI") Set oMail = oLook.CreateItem(0) 'Build the Recipient List With rst Do While Not .EOF strTO = strTO & ![EmailAddress] & ";" .MoveNext Loop End With olItem.Display olItem.To = strTO olItem.Subject = Date & ": Action Items| " & Me.txtTitle olItem.HTMLBody = Join(aBody, vbNewLine) olItem.Display 'Clears selected records DoCmd.Hourglass True DoCmd.SetWarnings False DoCmd.OpenQuery "qrySendActionItemsClear", acViewNormal, acReadOnly DoCmd.Hourglass False DoCmd.SetWarnings True Me.Refresh End Sub