Multiple emails from Access

Question

Using Access 2010, I have a form that allows me to email multiple recipients (separately) with the push of a button. It fetches a .pdf document and attaches it to each email being sent. Outlook is the email software used.

Is it possible to write code that will choose whatever email program the user has on their system?

Thanks for any help....here is the code.

Option Compare Database

Option Explicit

Public objOutlook As Object

Public Function SendEMail(Optional bSend As Boolean = True)

' SendEMail() auto sends email

' SendEMail(False) Opens email from the drafts folder

    On Error GoTo proc_err

    Dim objMailItem As Object

    Dim objFolder As Object

    Dim objNS As Object

    Dim objAttachment As Object

    Dim strTO As String

    Dim strSubject As String

    Dim strBody As String

    Dim strSQL As String

    Dim strPath As String

    Dim rsSend As DAO.Recordset

    Dim strContactName As String

    If OpenOutlook Then

        strSQL = "SELECT * FROM qryEmails WHERE Email=True"

        'Recordset from TblName of active records

        Set rsSend = CurrentDb.OpenRecordset(strSQL)

        Do While Not rsSend.EOF

            strTO = rsSend("txtName") & "<" & rsSend("ContactEmail") & ">"

            strSubject = "This Email"

            'Basic html coding tags

            '<p> = begin paragragh"

            '</p> = end paragragh"

            '  = space"

            strBody = "<p>Please see the attached document. " & "" & "</p>" & _

                      "<p> </p>" & _

                      "" & _

                      ""

            'Create a new Outlook Mail Item and insert data

            Set objMailItem = objOutlook.CreateItem(0)    ' 0 = olobjMailItem

            objMailItem.To = strTO

            objMailItem.Subject = strSubject

            objMailItem.HtmlBody = strBody

            objMailItem.Importance = 2    '2 = olImportanceHigh

            Set objAttachment = objMailItem.Attachments

            'Add additional attachments to every email

            'strPath = Current directory

            'rsSend("CustomerDirectory") subdirectory stored in table

            'letter.pdf hardcoded filename to attach

            strPath = Application.CodeProject.Path

            objAttachment.Add strPath & "" & rsSend("CustomerDirectory") & "\letter.pdf", 1

            If bSend Then

                'Auto sending email

                objMailItem.Send

            Else

                'Saving each email to Drafts folder, must then manually send

                objMailItem.Display

                objMailItem.Save

            End If

            rsSend.MoveNext

        Loop

    Else

        MsgBox "Could not start Outlook", vbExclamation, "Error"

    End If

PROC_EXIT:

    Set objMailItem = Nothing

    Set objOutlook = Nothing

    Exit Function

proc_err:

    MsgBox Err.Number & " " & Err.Description, vbOKOnly + vbCritical, "Error"

    objMailItem.Display

    Resume PROC_EXIT

    Resume

End Function

Public Function OpenOutlook(Optional strWhere As String = "Drafts") As Boolean

    Dim objMAPINamespace As Object

    On Error Resume Next

    'Get handle to Outlook if already open

    Set objOutlook = GetObject(, "Outlook.Application")

    'Create new Outlook object if not open

    If Err.Number = 429 Then

        Set objOutlook = CreateObject("Outlook.application")

    End If

    On Error GoTo 0

    Set objMAPINamespace = objOutlook.GetNamespace("MAPI")

    If objOutlook.ActiveExplorer Is Nothing Then

        If strWhere = "Drafts" Then

            ' Drafts folder

            objOutlook.Explorers.Add _

                    (objMAPINamespace.GetDefaultFolder(16), 0).Activate

        Else

            ' Inbox folder

            objOutlook.Explorers.Add _

                    (objMAPINamespace.GetDefaultFolder(6), 0).Activate

        End If

    Else

        If strWhere = "Drafts" Then

            ' Drafts folder

            Set objOutlook.ActiveExplorer.CurrentFolder = objMAPINamespace.GetDefaultFolder(16)

        Else

            ' Inbox folder

            Set objOutlook.ActiveExplorer.CurrentFolder = objMAPINamespace.GetDefaultFolder(6)

        End If

        'Make Outlook visible

        objOutlook.ActiveExplorer.Display

    End If

    OpenOutlook = True

End Function

Answer 1

Thanks Scott. It does help, thanks. Gets me a bit closer.

Answer 2

Thanks Daniel. I have searched the web and have not found anything. But I suspected that this might not be possible. I didn't have any particular program in mind. A client was asking if it was doable. Thanks again!

Answer 3

You can try not using Office Automation. The code you are using will only work with Outlook.

If you use the SendObject command, it will work with the default e-mail client. But its harder to attach a file using SendObject. You need to send a Report object formatted as a PDF.

Answer 4

Hi. The only other way I can think of is to use CDO (here's a demo). Just my 2 cents...

Answer 5

No.  While it might be possible to create a function for some other programs, the vast majority do not open themselves to automation in this manner.

What programs do you have in mind?  Have you searched existing functions online?