Send different Time Sheets to different email address from Access

Naveen D'Sozua
Naveen D'Sozua used Ask the Experts™
on
Hi There,

Let me start by saying I do not have a clue about Access other than use the existing database for entries and use the already customised  reports. Currently I have few databases that I use to enter the data and export the time sheets (which comes as one file) then extract each page and email them to individuals. The problem apart from being time consuming for doing 5 databases, the sensitivity of information (timesheets) are a stressful exercise every bi-weekly as we need to make sure the time sheets dont interchange or go to wrong person, has happened a couple of times in the past. Is there a way to Access to send the time sheets in PDF format to individuals for a specific period of time being rest assured it reaches the intended person. I can give information, but an heads up, it will be in a lay man's version.

Appreciate your help and advise.
Thanks & Regards
Naveen
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Distinguished Expert 2017

Commented:
This is going to be way over your head.  I pulled out a procedure from one of my apps that sends pdf's to customers.  A lot of the code deals with picking the correct email (we have two) and printing the report and logging that fact when there is no valid email.  The first part of the procedure deletes the contents of the errors table and opens a recordset to find all the people who will get the email.  Inside that "Do Until" loop, the PrintOrEmail procedure is called for each record.  You will also see code that gets the TestEmail because you don't want to be blasting out emails during your testing so a test email address is saved in a local table.  This allows people to customize the test email address to send the emails to themselves rather than to the same hard-coded address.  I highlighted the "read loop" so you can see what is controlling the emails.  Then the PrintOrEmail procedure figures out which email to use, creates a file name and deletes any existing file with that name and finally uses OutputTo to print the PDF and then it calls the Email_Via_Outlook() procedure to send the email with the attachment.
Good luck.
Private Sub cmdSendEmails_Click()
    Dim strValue As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim rs2 As DAO.Recordset
    Dim qd As DAO.QueryDef
    Dim td As DAO.TableDef
    Dim strMsg As String
    Dim StartTime As Date
    Dim EndTime As Date
    Dim stDocName As String
    Dim QUOTE As String
    Dim DocName As String
    Dim strPath As Variant
    Dim strSQL As String
    Dim CountErr As Integer
    Dim TestEmail As Boolean
    Dim strEmail As String
    Dim strTestEmail As String
    Dim strSubject As String
    
On Error GoTo ErrProc

    QUOTE = """"
    CountErr = 0
    Set db = CurrentDb()
    stDocName = "Inspectors report"
    TestEmail = DLookup("TestEmail", "tblEmail", "RecID = 1")
    strTestEmail = DLookup("TestEmailAddress", "tblEmail", "RecID = 1")
    
    'get path
    strPath = DLookup("FileFolder", "tblEMail", "RecID = 1")
    If strPath & "" = "" Then
        MsgBox "Please open email defaults form and add document path.", vbOKOnly
        Exit Sub
    End If
    If Right(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If

    'delete old email errors
    strSQL = "Delete * From tblNoEmailAddress"
    DoCmd.SetWarnings False
    DoCmd.Hourglass True
    DoCmd.RunSQL strSQL
    strSQL = "Delete * From tblEmailErrors"
    DoCmd.RunSQL strSQL
    DoCmd.SetWarnings True
    DoCmd.Hourglass False
    
    'open email error recordset.
    Set td = db.TableDefs!tblNoEmailAddress
    Set rs2 = td.OpenRecordset
    
    
    Set qd = db.QueryDefs!qGetIRDataJobs
    Set rs = qd.OpenRecordset
    
    StartTime = Now()
    Me.lblElapsedTime.Visible = False
    Me.lblStatus.Visible = True
    Me.lblStatus.Caption = "Sending Emails...."
    Me.Recalc
    DoEvents
    DoCmd.Hourglass (True)
    
    ' Create the Outlook session.
        'Set oOL = CreateObject("Outlook.Application")
        'Set oOL = New Outlook.Application
    On Error Resume Next
    Set oOL = GetObject(, "Outlook.Application")

    If Err.Number = 429 Then
        Set oOL = CreateObject("Outlook.application")
    End If

    On Error GoTo ErrProc


    If Me.txtJob & "" = "" Then
        Do Until rs.EOF = True  '''''''''''''''''''''''''''''read loop
            Me.txtJob = rs!Job
            GoSub PrintOrEmail
            rs.MoveNext
        Loop                    '''''''''''''''''''''''''''''read loop
    Else
        rs.FindFirst "Job = '" & Me.txtJob & "'"
        GoSub PrintOrEmail
    End If
    'Close outlook session
    Set oOL = Nothing
    
    DoCmd.Hourglass (False)
    DoCmd.SetWarnings (True)
    Me.lblStatus.Caption = "Complete"
    EndTime = Now()
    Me.lblStatus.Visible = True
    Me.lblElapsedTime.Visible = True
    Me.lblElapsedTime.Caption = DateDiff("n", StartTime, EndTime) & " Minutes"
    
    'close recordsets
    rs.Close
    rs2.Close
    If CountErr > 0 Then
        DoCmd.OpenReport "rptNoEmailAddress", acViewPreview
    Else
        MsgBox "All reports were emailed.", vbOKOnly
    End If
    If DCount("*", "tblEMailErrors") > 0 Then
        DoCmd.OpenReport "rptEMailErrors", acViewPreview
    End If
ExitProc:
    Exit Sub
    
PrintOrEmail:
    DocName = strPath & rs!Job & "_Ending_" & Format(Me.txtThruDate, "yyyymmdd") & ".pdf"
    strSubject = "Quantity Review Report for " & rs!Job & " Date ending " & Me.txtThruDate
    If rs!IR_Email & "" = "" Then
        If rs!IR_Email2 & "" = "" Then
            DoCmd.OpenReport stDocName, acViewNormal
            rs2.AddNew
                rs2!Job = Me.txtJob
                rs2!PrintDate = Now()
            rs2.Update
            CountErr = CountErr + 1
        Else            'send only to alternate
            Kill DocName    'delete existing file if any so outputto won't hang
            DoCmd.OutputTo acOutputReport, stDocName, acFormatPDF, DocName, False
            ' send the PDF via outlook
            If TestEmail = True Then
                strEmail = strTestEmail ' "mfalaguerra@safetymarking.net"
            Else
                strEmail = rs!IR_Email2
            End If
            strValue = Email_Via_Outlook(strEmail, strSubject, Me.txtMsg, False, DocName)
        End If
    Else
        Kill DocName    'delete existing file if any so outputto won't hang
        DoCmd.OutputTo acOutputReport, stDocName, acFormatPDF, DocName, False
        ' send the PDF via outlook
        If TestEmail = True Then
            strEmail = strTestEmail ' "mfalaguerra@safetymarking.net"
        Else
            strEmail = rs!IR_Email
        End If
        
        strValue = Email_Via_Outlook(strEmail, strSubject, Me.txtMsg, False, DocName)
        
        'send to alternate email
        If TestEmail = True Then
            strEmail = strTestEmail ' "mfalaguerra@safetymarking.net"
        Else
            strEmail = rs!IR_Email2
        End If
        
        strValue = Email_Via_Outlook(strEmail, strSubject, Me.txtMsg, False, DocName)
        
    End If
    Return
ErrProc:
    Select Case Err.Number
        Case 53 'file not found
            Resume Next
        Case Else
            MsgBox Err.Number & "--" & Err.Description
            Resume Next
    End Select
    
End Sub
Function Email_Via_Outlook(vAddress, vSubject, vBody, DisplayMsg As Boolean, Optional strFileName)

Dim oMailItem As Outlook.MailItem
Dim oRecip As Outlook.Recipient
Dim oAttach As Outlook.Attachment
Dim db As DAO.Database
Dim td As DAO.TableDef
Dim rs As DAO.Recordset
Dim AttPath As String
Dim strSQL As String
On Error GoTo ErrProc
    Set db = CurrentDb()
    Set td = db.TableDefs!tblEmail
    Set rs = td.OpenRecordset
    AttPath = strFileName

' Create the message.
Set oMailItem = oOL.CreateItem(olMailItem)

    ' Add the To recipient(s) to the message.
    Set oRecip = oMailItem.Recipients.Add(vAddress)
    oRecip.Type = olTo
    oMailItem.Subject = vSubject
    oMailItem.body = vBody
'    oMailItem.SendUsingAccount = rs!eMailOnBehalfOf
 
    ' Add attachments to the message.
    If Not IsMissing(AttPath) And AttPath <> "" Then
        Set oAttach = oMailItem.Attachments.Add(AttPath)
    End If
 
    ' Resolve each Recipient's name.
    For Each oRecip In oMailItem.Recipients
        oRecip.Resolve
    Next
    ' Should we display the message before sending?
    If DisplayMsg Then
        oMailItem.Display
    Else
        oMailItem.Save
        oMailItem.Send
    End If


ExitProc:
    Exit Function

ErrProc:
    Select Case Err.Number
        Case Else
            MsgBox Err.Number & "--" & Err.Description
            strSQL = "Insert Into tblEmailErrors (Job, PrintDate, EMail, FileName, ErrNum, ErrDesc) "
            strSQL = strSQL & " Values("
            strSQL = strSQL & QUOTE & Forms!dtepkr!txtJob & QUOTE & ", Now(), " & QUOTE & vAddress & QUOTE & ", " & QUOTE & strFileName & QUOTE
            strSQL = strSQL & ", " & Err.Number & ", " & QUOTE & Err.Description & QUOTE & ");"
            DoCmd.RunMacro "mWarningsOff"
            DoCmd.RunSQL strSQL
            DoCmd.RunMacro "mWarningsOn"
            Resume Next
    End Select
 
End Function

Open in new window

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial