Hello All!
I have a new question, and you all were so very helpful with my last set of questions a few months ago.
I run a day camp. Each unit has around 15 people, though a few have much fewer and one has many more.
I usually send an e-mail to the unit leaders with their unit information, including contact information, in a table with-in the e-mail.
I would dearly love to be able to automate this.
I have been playing around and i have a pretty good start, but I'm running into a few issues, not the least of which is that if a field should be empty (i.e. adults don't have a parent/guardian and campers don't have a unit position), then the information is copied from the table row above it. When I create multiple e-mails, the fields copy from the e-mail created before it!
Example: a unit has three people, Sarah Smith, unit leader, smith@aol.com, adult #1 {blank}, cell #1 is 123-456-7896; Holly Hobby, {no position, she's a kid}, hobby@att.net, Amanda Hobby, 456-789-1234; Emily Evans, {no position}, evans@orb.com, Tracey Evans, 789-123-4567
The table should look like:
Name Position Adult #1 cell #1
Sarah Smith UL 123-456-7896
Holly Hobby Amanda Hobby 456-789-1234
Emily Evans Tracey Evans 789-123-4567
Instead I get:
Name Position Adult #1 cell #1
Sarah Smith UL ** 123-456-7896 **if there was another e-mail before this one, then this would be the parent from the last record
Holly Hobby UL Amanda Hobby 456-789-1234
Emily Evans UL Tracey Evans 789-123-4567
So .... how do I keep the blank fields blank?
My code is: OH! and I forgot to mention, I must use late binding ... hence the "objects."
Code:
Dim objOutlook As Object
Dim objEmailItem As Object
Dim dbs As DAO.Database
Dim strPath As String
Dim NewFileName As String
Dim UnitName As String
Dim ULName As String
Dim ULemail As String
Dim BodyText As String 'this is typed into a form
Dim SubjText As String 'this is typed into a form
Dim varItem As Variant
Dim lst As Access.ListBox
Dim tblRow(1 To 9) As String
Dim tblHeader(1 To 9) As String
Dim tblBody() As String
Dim LineCnt As Long
Dim rstTable As DAO.Recordset
Dim strQry As String
Set lst = Me.lstULs
'Check to make sure at least one unit is selected
If lst.ItemsSelected.Count = 0 Then
MsgBox "No units selected. Please select a unit.", vbOKOnly
Exit Sub
End If
'prevent 429 error if Outlook is not open
On Error Resume Next
Err.Clear
'See if Outlook is open
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
'Should open Outlook
Set objOutlook = CreateObject("Outlook.Application")
End If
BodyText = Me.txtEmailBody
SubjText = Me.txtSubjLine
' olMailItem is the Outlook Application's constant,
' therefore define it here explicitly
Const olMailItem As Long = 0
For Each varItem In lst.ItemsSelected
'Build the table of unit info
'Create Header Row
tblHeader(1) = "First"
tblHeader(2) = "Last"
tblHeader(3) = "Unit Position" 'campers don't have a unit position
tblHeader(4) = "Days" 'Days attending
tblHeader(5) = "E-mail"
tblHeader(6) = "Adult #1" 'adults don't have an adult #1
tblHeader(7) = "Cell #1" 'everyone has a cell #1
tblHeader(8) = "Adult #2" 'adults and some campers don't have an adult #2
tblHeader(9) = "Cell #2" 'adults and some campers don't have a cell #2
'set up count of body rows
LineCnt = 1
ReDim tblBody(1 To LineCnt)
tblBody(LineCnt) = "<HTML><body><table border='1'><tr><th>" & Join(tblHeader, "</th><th>") & "</th></tr>"
'Create each table row
strQry = "SELECT [qry Roster].FirstName, [qry Roster].LastName, [qry Roster].PositionName, [qry Roster].Days, " & _
"[qry Roster].email, [qry Roster].ParentGuard1, [qry Roster].cellnumber, [qry Roster].parentguard2, " & _
"[qry Roster].Cell2 FROM [qry Roster] WHERE ((([qry Roster].UnitID) = " & lst.ItemData(varItem) & ")) " & _
"ORDER BY [qry Roster].UnitID, [qry Roster].Type, [qry Roster].Position, [qry Roster].LastName, " & _
"[qry Roster].FirstName;"
Set dbs = CurrentDb
Set rstTable = dbs.OpenRecordset(strQry, dbOpenDynaset, dbReadOnly)
If Not (rstTable.BOF And rstTable.EOF) Then
Do While Not rstTable.EOF
LineCnt = LineCnt + 1
ReDim Preserve tblBody(1 To LineCnt)
tblRow(1) = rstTable("FirstName")
tblRow(2) = rstTable("LastName")
tblRow(3) = rstTable("PositionName")
tblRow(4) = rstTable("Days")
tblRow(5) = rstTable("Email")
tblRow(6) = rstTable("ParentGuard1")
tblRow(7) = rstTable("cellnumber")
tblRow(8) = rstTable("ParentGuard2")
tblRow(9) = rstTable("cell2")
tblBody(LineCnt) = "<tr><td>" & Join(tblRow, "<td>") 'I originally had /td and /tr end tags, but the tags appeared in the actual table, so I took them out
rstTable.MoveNext
Loop
End If
tblBody(LineCnt) = tblBody(LineCnt) & "</table></body></html>"
'Build e-mail message
'pull UL FirstName
ULName = DLookup("FirstName", "qry UL List", "UnitID=" & lst.ItemData(varItem))
'pull UL e-mail address
ULemail = DLookup("email", "qry UL List", "UnitID=" & lst.ItemData(varItem))
Set objEmailItem = objOutlook.CreateItem(olMailItem)
With objEmailItem
'Who the e-mail is to ... use .CC for carbon copy and .bcc for blind carbon copy
.to = ULemail
'What the subject line is
.Subject = SubjText
'using HTML so the font and size can be changed. <br> is a carriage return
'original htmlbody
'eventually I want the table to be in between the BodyText and my signature
' .htmlbody = "<BODY style=font-size:12pt;font-family:Calibri>" & ULName & ",<br><br>" & _
' BodyText & "<br><br>Susie Gilson<br>Girl Scouts<br>" & _
' "Day Camp Business Manager" & _
' "<br>SU 678<br>email@att.net</BODY>"
'html table test
.htmlbody = Join(tblBody, vbNewLine)
'Display the e-mail rather than sending it
.Display
End With
'have the e-mail item be visible
objOutlook.visble = True
Set objEmailItem = Nothing
rstTable.Close
Set rstTable = Nothing
'Move to next item in the list
Next
The building of the e-mail itself ... finding the leader's name, e-mail and doing the original HTML body work just fine.
Thank you!
Susie
A weary Girl Scout in Kansas