Email with Looping Attachments and HTML Table

[david_johnson_CR]

Greetings,

I have scoured the site to find this exact issue and I haven't been successful. I have a table of applicants and a table of projects (applicants have one or more projects). For each applicant, an email is created and for each project a word document is created, saved, and attached to that email. I also need an html table to generate that has key elements from each project record. I have done both before but never together and there's something I'm missing, I'm pretty sure it's the placement of key bits of code. The problem I have is that when the table generates within the email, it only has the last project in the loop. That's what makes me think it has something to do with placement but I can't pin down the solution. Any help would be most greatly appreciated.

Thanks!

Private Sub generate_quarterly_reports_Click()

Dim objWord As Word.Application
Dim d As DAO.Database
Dim r As Recordset
Dim docname As String
Set d = CurrentDb()
Dim q As Recordset
Set q = d.OpenRecordset("QR_app_data_tbl")
Dim GCEmail As String
Dim RCEmail As String
Dim COEmail As String
Dim send_date As Date
Dim olApp As Object
Dim olItem As Variant
Dim EmailBody As String
Dim str_app_SQL As String
Dim Disaster As String
'Dim aBody() As String
Dim COEmailBackup As String
Dim strQry As String
Dim TeamLeadEmail As String
Dim COEntity As String
Dim GCName As String
Dim GCPhone As String
Dim recipient As String
Dim quarter_year As String
Dim quarter_q As String
Dim app_id As String
Dim aHead(1 To 3) As String
Dim aRow(1 To 3) As String
Dim aBody() As String
Dim lCnt As Long
Dim asPreTable As String
Set d = CurrentDb
    
send_date = Date
quarter_year = "2018"
quarter_q = "Q1"

Set olApp = CreateObject("Outlook.application")
'Begin Applicant-level loop
If Not q.BOF And Not q.EOF Then
    q.movefirst
    Do
    
    Set olItem = olApp.CreateItem(0)
        
    'Gather data from table to construct email
    app_id = q!applicant_ID
    GCEmail = DLookup("GC_Email", "QR_app_data_tbl", "applicant_ID = '" & app_id & "'")
    RCEmail = DLookup("RC_Email", "QR_app_data_tbl", "applicant_ID = '" & app_id & "'")
    COEmail = DLookup("CO_Email", "QR_app_data_tbl", "applicant_ID = '" & app_id & "'")
    COEmailBackup = DLookup("CO_Alt_Email", "QR_app_data_tbl", "applicant_ID = '" & app_id & "'")
    COEntity = DLookup("applicant", "QR_app_data_tbl", "applicant_ID = '" & app_id & "'")
    GCName = DLookup("GC_Name", "QR_app_data_tbl", "applicant_ID = '" & app_id & "'")
    GCPhone = DLookup("GC_Phone", "QR_app_data_tbl", "applicant_ID = '" & app_id & "'")
    Disaster = DLookup("disaster", "QR_app_data_tbl", "applicant_ID = '" & app_id & "'")
    
    
    'Post Table Email Text
    EmailBody = "Greetings, <br>" _
                & "<br>Please find attached a <i>Notice of Administrative Change </i>from the Texas Division of Emergency Management. These changes may affect your Public Assistance subgrants for disaster declarations occurring between January 1, 2015 and December 31, 2016. <br><br>" _
                & "Please contact your Grant Coordinator at " & GCEmail & " with any questions." _
                & "<br><br>Respectfully,<br>" _
                & GCName & " " _
                & "<br><br><b>" & GCName & "</b><br>" _
                & "Government and Public Sector<br>" _
                & "CohnReznick Advisory<br>" _
                & "Tel: " & GCPhone & "" _
                & "<br>Fax: 512-494-9101" _
                & "<br><u><font color=""blue"">" & GCEmail & "</u></font>" _

    'Quick-fix for Applicant having no POC backup
    If COEmail = COEmailBackup Then
        recipient = COEmail
    Else
        recipient = COEmail & "; " & COEmailBackup
    End If
    
    'Outlook items (except html body and attachments)
    With olItem
        .ReplyRecipients.Add GCEmail
        .To = recipient
        .Subject = "DR-" & Disaster & " | " & COEntity & " | Quarterly Report"
       '.ReadReceiptRequested = True
        .OriginatorDeliveryReportRequested = True
        .CC = GCEmail & "; " & "; " & RCEmail
        .bcc = "communications@crmail.getadvantage.com"
        .SentOnBehalfOfName = "recovery.communications@cohnreznick.com"
    End With
   
    
    'Setting parameters for project-level loop
    strQry = "SELECT * from QR_pw_data_tbl WHERE applicant_ID = '" & app_id & "'"
    Set d = CurrentDb
    Set r = CurrentDb.OpenRecordset(strQry)

    'Starts loop which contains email table and Word merge/attachment
    If Not r.EOF Then
        Do
        Set objWord = CreateObject("Word.Application")
        With objWord
            'Make the application visible.
            .Visible = True

            'Open the document.
            .Documents.Open ("H:\pmo_processes\quarterly_reports\quarterly_report_template.docx")

            'Move to each bookmark and insert text from the form.
            .ActiveDocument.Bookmarks("date").Select
            .Selection.Text = (CStr(r.Fields("date")))

            .ActiveDocument.Bookmarks("applicant").Select
            .Selection.Text = (CStr(r.Fields("applicant")))

            .ActiveDocument.Bookmarks("disaster_number").Select
            .Selection.Text = (CStr(r.Fields("disaster")))

            .ActiveDocument.Bookmarks("est_completion_date").Select
            .Selection.Text = (CStr(r.Fields("est_completion_date")))

            .ActiveDocument.Bookmarks("extended_date").Select
            .Selection.Text = (CStr(r.Fields("extended_date")))

            .ActiveDocument.Bookmarks("PA_ID").Select
            .Selection.Text = (CStr(r.Fields("PA_ID")))

            .ActiveDocument.Bookmarks("pw").Select
            .Selection.Text = (CStr(r.Fields("pw")))

            .ActiveDocument.Bookmarks("pw_amount").Select
            .Selection.Text = (CStr(r.Fields("pw_amount")))
    
            .ActiveDocument.Bookmarks("pw_completion_date").Select
            .Selection.Text = (CStr(r.Fields("pw_completion_date")))

            .ActiveDocument.Bookmarks("te_given").Select
            .Selection.Text = (CStr(r.Fields("te_given")))
        End With

        'Name document before saving
        docname = "h:\pmo_processes\quarterly_reports\reports_generated\" & quarter_year & "_" & quarter_q & "\QR" & "_" & quarter_year & "_" & quarter_q & "_" & COEntity & "_DR" & Disaster & "_PW" & Format(r.Fields("pw"), "00000") & ".doc"
  
    
        'Print the document in the foreground so Microsoft Word will not close
        'until the document finishes printing.
        objWord.ActiveDocument.SaveAs FileName:=docname, _
        FileFormat:=wdFormatDocument
    
        'Close the document without saving changes.
        objWord.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges

        'Quit Microsoft Word and release the object variable.
        objWord.Quit
        Set objWord = Nothing
        
        'Begins table creation
        aHead(1) = "Project Worksheet Number"
        aHead(2) = "Application Title"
        aHead(3) = "Project Completion Report (P.4) Received"
   
        asPreTable = "Greetings, <br>" _
               & "<br>We are contacting you in reference to your FEMA Public Assistance (PA) Large Project(s) associated with DR-" & Disaster & ".  According to our records, Quarterly Reports must be submitted for the projects listed below.   A Quarterly Report is required for all large projects for which we have not received a Project Completion and Certification Report (P.4).<br><br>" _

        lCnt = 1
        ReDim aBody(1 To lCnt)
        aBody(lCnt) = "<HTML><body>" & asPreTable & "<table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
   
            lCnt = lCnt + 1
            ReDim Preserve aBody(1 To lCnt)
            aRow(1) = r("pw")
            aRow(2) = r("title")
            aRow(3) = r("p4")
            aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
    
            aBody(lCnt) = aBody(lCnt) & "</table>" & EmailBody & "</body></html>"
    
        'Adds attachment into Outlook
        With olItem
            Dim MyAttachments As Variant
            Set MyAttachments = olItem.attachments
            MyAttachments.Add docname
            .Save
        End With

        r.MoveNext
        Loop Until r.EOF
    End If
       
    'Adds body to email
    With olItem
       .htmlbody = "<HTML><body>" & Join(aBody, vbNewLine) & "</body></html>"
       .Save
    End With
       
    'Add to Log
    Dim email_log As DAO.Recordset
    Set email_log = CurrentDb.OpenRecordset("sent_email_log")
    email_log.AddNew
    email_log!sent_email_log_from = "recovery.communications@cohnreznick.com"
    email_log!sent_email_log_to = recipient & "; " & "; " & RCEmail & "; " & GCEmail & TeamLeadEmail & "; "
    email_log!sent_email_log_date_sent = Now()
    email_log!sent_email_log_subject = "DR-" & Disaster & " | " & COEntity & " | Quarterly Report"
    email_log!applicant_name = COEntity '
    email_log.Update
  
    'moves to next Applicant
    q.MoveNext
    Loop Until q.EOF
 
End If
MsgBox "Email Generation Complete"
Exit Sub

MergeButton_Err:
    'If a field on the form is empty, remove the bookmark text, and
    'continue.
    If Err.Number = 94 Then
       objWord.Selection.Text = ""
       Resume Next '''
'
'    'If the Photo field is empty.
    ElseIf Err.Number = 2046 Then
        MsgBox "Please add a photo to this record and try again."
    Else
        MsgBox Err.Number & vbCr & Err.Description
    End If

    Exit Sub
End Sub

 

[MarkK]

This routine is too long. This should be broken down into manageable subroutines so you can debug it in bits, and so that doing edits doesn't break it. To me, just trying to find where your loops are terminated is difficult, and it's that kind of doesn't-make-sense-at-a-glance complexity where bugs appear and begin to breed.

Aren't these the steps you are taking?

dim email
dim worddoc
Open a recordset
For each row in the recordset
   email = CreateAnEmail(using recordset row data)
   worddoc = CreateAWordDoc(using recordset row data)
   email.attach worddoc
   CreateLogEntry email, worddoc
Next

If so, then that's what the main routine should look like. You want to be able to see the recordset, see the loop, and see the short list of things this routine does. Then, for CreateAnEmail(), start a whole new Function whose only job is create the email and return it to the calling routine. If creating the email body starts to get complicated, fine, new Function GetEmailBody(GCName as string) As String. Obvious. Simple.

This makes writing code way easier because it makes reading code way easier. It makes your code much simpler and much more robust, because each subroutine can be named for exactly what it does, can be tested on it's own, and editing code in other routines can never break the code in this one. Also, the many lines of detailed subroutine code no longer obscure your view of the structure of your higher level code, including your loops, and how those loops are controlled.

hth
Mark