Ms-access – Access Send Email. Loop Not Building Table

codems accessscripting

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.

–adam

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

enter image description here

Best Answer

The problem was with the comments field. I had the field set to Rich Text and I was exporting Plain text on the query. [Comment(s):PlainText([Comments] For some reason, if it got to a record with rich text it stopped the Loop. I changed the query to lose the PlainText and it works.

Why.... unknown. The DB Gods must have thought I suffered enough for today.

Related Question