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) = "" & Join(aHead, "") & ""
'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) = "" & Join(aRow, "") & ""
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & ""
'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
Asked by AdamB
(88 rep)
Feb 11, 2017, 10:27 PM
Last activity: Feb 11, 2017, 11:58 PM
Last activity: Feb 11, 2017, 11:58 PM