Create and Print an Email (1 Viewer)

[david_johnson]

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!

 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

 

[isladogs]

If you use the forum search you will find several threads relating to this issue including at least one in the last week or so

 

[david_johnson]

Thanks - Can you provide the link to one? I see plenty of posts about sending emails and printing reports. The only thread I've been able to find about creating an email and then printing that email is my own, but I can certainly accept I'm just missing them all. Thanks!