david_johnson_CR
New member
- Local time
- Today, 08:04
- Joined
- Dec 5, 2017
- Messages
- 7
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!
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!
Code:
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