I'm having a hard time getting a formatted table into an email through Access VBA. I can get it to create one giant table for everything in the recordset, but I need one table for each check number (a field in the record set). Any ideas?
I've tried so many variations of code - I thought I might need the arow in arow(1-9) to be dynamic, but I can't figure that piece out.
Here's what I have to make the one giant table:
Dim olApp As Object
Dim olItem As Variant
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strQry As String
Dim aHead(1 To 8) As String
Dim aRow(1 To 8) As String
Dim aBody() As String
Dim lCnt As Long
Dim strpicpath As String
Dim appoutlook As Outlook.Application: Set appoutlook = New Outlook.Application
Dim mimEmail As Outlook.MailItem
Set mimEmail = appoutlook.CreateItem(olMailItem)
'strpicpath = "path"
'Create the header row
aHead(1) = "End Debtor Name"
aHead(2) = "Invoice"
aHead(3) = "Check Number"
aHead(4) = "Exception Type"
aHead(5) = "Amount"
aHead(6) = "Actions to Resolve"
aHead(7) = "Notes"
aHead(8) = "Client Response"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
'Create each body row
strQry = "SELECT * From tbl_SendEmailsTemp"
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("EndDebtor Name")
aRow(2) = rec("Invoice #")
aRow(3) = rec("Check Number1")
aRow(4) = rec("Exception Type")
aRow(5) = rec("Balance")
aRow(6) = rec("Notes")
aRow(7) = ""
aRow(8) = ""
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
'create the email
With mimEmail
.To = "test"
'.To = ContactEmail & ";" & ContactEmail2 & ";" & ContactEmail3
'.cc = creditrep & ";" & "credit "
.Subject = Client_Name & ", Exceptions Report, " & Date - 1
Dim att As Outlook.Attachment
Set att = .Attachments.Add(strpicpath, 1, 0)
.HTMLBody = "<img src=""Exceptions.png""><br><br><br>" _
& "<BODY style = font-size: 11pt>Please see below for the exceptions generated from " & Date - 1 & " transactions. All applicable back-up documentation is attached:</BODY><br><br>" _
& Join(aBody, vbNewLine) & " <br><br>"
.Display
End With
DoCmd.OpenQuery "qry_AppendEmailed"
DoCmd.OpenQuery "qry_AppendNotEmailed"
DoCmd.OpenQuery "qry_DeleteFromExceptions"
DoCmd.SetWarnings True
End Sub
You can use a single recordset, as long as you order by check number (untested):
Sub tester()
Const olMailItem As Long = 0 'late binding so need this Outlook constant
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strQry As String
Dim headers, widths, checkNo, currCheckNo, tableHTML As String, tblStart As String, rowInfo
Dim strpicpath As String
Dim appoutlook As Object, mimEmail As Object
headers = Array("End Debtor Name", "Invoice", "Check Number", "Exception Type", _
"Amount", "Actions to Resolve", "Notes", "Client Response")
widths = Array("100px", "120px", "80px", "130px", _
"200px", "100px", "50px", "90px")
tblStart = "<table border='2'>" & TableRow("th", headers, widths)
'query is ordered by check number
strQry = "SELECT * From tbl_SendEmailsTemp order by [Check Number1]"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
currCheckNo = Chr(0)
tableHTML = ""
If Not (rec.BOF And rec.EOF) Then
Do While Not rec.EOF
checkNo = rec("Check Number1").Value
If checkNo <> currCheckNo Then 'start new table?
'close off previous table?
If Len(tableHTML) > 0 Then tableHTML = tableHTML & "</table>"
tableHTML = tableHTML & tblStart 'start new table
currCheckNo = checkNo
End If
rowInfo = Array(rec("EndDebtor Name"), rec("Invoice #"), _
checkNo, rec("Exception Type"), _
rec("Balance"), rec("Notes"), "", "")
tableHTML = tableHTML & TableRow("td", rowInfo)
rec.MoveNext
Loop
tableHTML = tableHTML & "</table>" 'close off last table
End If
'create the email
Set appoutlook = CreateObject("Outlook.Application")
Set mimEmail = appoutlook.CreateItem(olMailItem)
With mimEmail
.To = "test"
'.To = ContactEmail & ";" & ContactEmail2 & ";" & ContactEmail3
'.cc = creditrep & ";" & "credit "
.Subject = Client_Name & ", Exceptions Report, " & Date - 1
Dim att As Outlook.Attachment
Set att = .Attachments.Add(strpicpath, 1, 0)
.HTMLBody = "<html><body style='font-size: 11pt'><img src='Exceptions.png'><br><br><br>" _
& "Please see below for the exceptions generated from " & Date - 1 & _
" transactions. All applicable back-up documentation is attached:<br><br>" _
& tableHTML & "<br><br></body></html>"
.Display
End With
DoCmd.OpenQuery "qry_AppendEmailed"
DoCmd.OpenQuery "qry_AppendNotEmailed"
DoCmd.OpenQuery "qry_DeleteFromExceptions"
DoCmd.SetWarnings True
End Sub
'Given an array of values, create an HTML table header or body row
' optionally provide an array of widths for each column
Function TableRow(cellType As String, arrTexts, Optional arrWidths) As String
Dim el As String, w As String, html As String, i As Long
html = "<tr>"
For i = LBound(arrTexts) To UBound(arrTexts)
el = arrTexts(i)
If Not IsMissing(arrWidths) Then w = " style=""width:" & arrWidths(i) & """"
html = html & "<" & cellType & w & ">" & el & "</" & cellType & ">"
Next i
TableRow = html & "</tr>"
End Function