david_johnson
Registered User.
- Local time
- Today, 13:39
- Joined
- Oct 12, 2017
- Messages
- 12
Greetings,
I'm doing some work for a government agency so there are all sorts of "fun" records retention requirements that might seem atypical. I'm needing to create emails based on a table (which is all done and working perfectly) but it would also be very beneficial to be able to automatically save those emails as PDFs so that the user doesn't have to do that manually. I can and have done that with Access Reports before, but I'm not certain how to do that with an email created in Outlook. I've included my code in case it's helpful/relevant, but any help you can provide would be most appreciated. Thanks!
I'm doing some work for a government agency so there are all sorts of "fun" records retention requirements that might seem atypical. I'm needing to create emails based on a table (which is all done and working perfectly) but it would also be very beneficial to be able to automatically save those emails as PDFs so that the user doesn't have to do that manually. I can and have done that with Access Reports before, but I'm not certain how to do that with an email created in Outlook. I've included my code in case it's helpful/relevant, but any help you can provide would be most appreciated. Thanks!
Code:
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 5) As String
Dim aRow(1 To 5) As String
Dim aBody() As String
Dim lCnt As Long
Dim asPreTable As String
Dim asPostTable As String
Dim appsrec As DAO.Recordset
Dim str_app_SQL As String
Dim ApplicantID As Integer
Dim AppEmail As String
'Dim SAEmail As String
Dim AppName As String
Dim RCEmail As String
Dim GCEmail As String
Dim GCName As String
Dim GCBackupEmail As String
'Dim strFrom As String
Dim recovery_communications_non_portal_use As DAO.Database
Dim GCPhone As String
Dim altAppEmail As String
Dim email_log As DAO.Recordset
Set recovery_communications_non_portal_use = CurrentDb
Set email_log = recovery_communications_non_portal_use.OpenRecordset("sent_email_log")
str_app_SQL = "SELECT * FROM applicant_list"
Set appsrec = CurrentDb.OpenRecordset(str_app_SQL)
If Not appsrec.BOF And Not appsrec.EOF Then
appsrec.MoveFirst
Do While Not appsrec.EOF
AppEmail = DLookup("applicant_email", "applicant_list", "applicant_list_ID = " & appsrec!applicant_list_ID)
altAppEmail = DLookup("alt_DAA_email", "applicant_list", "applicant_list_ID = " & appsrec!applicant_list_ID)
'MsgBox AppEmail
' SAEmail = DLookup("contact_email", "contacts_table_primary", "applicant_ID = " & appsrec!applicant_list_ID & " AND [contact_role] = 'Section Administrator'")
RCEmail = DLookup("RCEmail", "applicant_list", "applicant_list_ID = " & appsrec!applicant_list_ID)
GCEmail = DLookup("GCEmail", "applicant_list", "applicant_list_ID = " & appsrec!applicant_list_ID)
GCName = DLookup("contact_name", "contacts_table_primary", "applicant_ID = " & appsrec!applicant_list_ID & " AND [contact_role] = 'Grant Coordinator'")
GCPhone = DLookup("contact_phone", "contacts_table_primary", "applicant_ID = " & appsrec!applicant_list_ID & " AND [contact_role] = 'Grant Coordinator'")
AppName = DLookup("applicant_name", "applicant_list", "applicant_list_ID = " & appsrec!applicant_list_ID)
' GCBackupEmail = DLookup("contact_email", "contacts_table_primary", "applicant_ID = " & appsrec!applicant_list_ID & " AND [contact_role] = 'Grant Coordinator - Alternate'")
' Create the header row
' aHead(1) = "Agency"
' aHead(2) = "Role"
' aHead(3) = "Name"
' aHead(4) = "Phone"
' aHead(5) = "Email"
asPreTable = "Good Morning, <br>" _
& "<br>FEMA's Grants Portal is a collaborative workspace that requires your input in managing your entity's Hurricane Harvey damage inventory list, uploading supporting documentation, as well as reviewing and signing off on damage dimensions and descriptions, and ultimately, your projects' scope of work and costs. <br><br>" _
asPostTable = "Public Assistance Program Applicants are required to utilize this system for developing projects (Project Worksheets). If you have not done so already, please sign into the FEMA Grants Portal at <a href=""" & "https://grantee.fema.gov/" & """>" & "https://grantee.fema.gov/" & "</a>. If you cannot locate your username or password, or have other difficulties accessing Grants Portal, please contact your TDEM Grant Coordinator at " & GCEmail & " at your earliest convenience." _
& "<br><br>Best Regards,<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>" _
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body>" & asPreTable
'Create each body row
strQry = "SELECT * From contacts_table_primary WHERE applicant_ID = " & appsrec!applicant_list_ID
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("contact_agency")
aRow(2) = rec("contact_role")
aRow(3) = rec("contact_name")
aRow(4) = rec("contact_phone")
aRow(5) = rec("contact_email")
' aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & asPostTable & "</body></html>"
'create the email
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
'olItem.from = strFrom
olItem.ReplyRecipients.Add GCEmail
'olItem.display
If altAppEmail = AppEmail Then
olItem.To = AppEmail
Else
olItem.To = AppEmail & "; " & altAppEmail
End If
olItem.Subject = "DR-4332 | " & AppName & " | Logging into FEMA Grants Portal - Action Required"
olItem.CC = RCEmail & "; " & GCEmail & "; " & GCBackupEmail
olItem.bcc = "communications@crmail.getadvantage.com"
olItem.htmlbody = Join(aBody, vbNewLine)
olItem.SentOnBehalfOfName = "recovery.communications@cohnreznick.com"
olItem.Save
' olItem.Close
' olItem.display
email_log.AddNew
email_log!sent_email_log_from = "recovery.challenges@cohnreznick.com"
email_log!sent_email_log_to = AppEmail & "; " & "; " & RCEmail & "; " & GCEmail
email_log!sent_email_log_date_sent = Now()
email_log!sent_email_log_subject = "DR-4332 | " & AppName & " | Logging into FEMA Grants Portal - Action Required"
email_log!applicant_name = AppName
' email_log!sent_email_log_body = Join(aBody, vbNewLine)
email_log.Update
appsrec.MoveNext
Loop
End If
appsrec.Close
Set appsrec = Nothing
End Sub
