Multiple Apps

Send mailmerged documents individually via Outlook

Ease of Use

Intermediate

Version tested with

2000 

Submitted by:

geekgirlau

Description:

This procedure allows you to use any Access table or query as the data source for a mailmerge. The records are merged individually to an MS Word document, then attached to individual emails. 

Discussion:

The vast majority of databases contain at least one table and/or query that could potentially be used for a mail merge. This form lists all tables and queries in the database, so the user can nominate the data source for the mail merge. All the fields from the selected table or query are then displayed so that the user can nominate the name of the field that contains the email address. This could be either a name that appears in your Global Address list in Outlook, or an external email address such as customer@hotmail.com. The user then selects the mailmerge document (that may or may not have merge fields in it) using a standard "open" dialog box. This mailmerge document does not have to be linked to your data source, and doesn't necessarily have to contain any merge fields at all, allowing you to email documents such as generic flyers or brochures. Finally they set email options such as the subject, the importance, read and delivery receipts, and whether to display the email prior to sending. Any email addresses that Outlook could not process will appear in an error message at the end of the process. However if Outlook thinks it might be a valid external email, it will attempt to send it, and you will later receive an "undeliverable" email message. Please note that unless you have a utility such as Redemption, you will also see a security warning message for each email that you send, and you will have to click "Yes" for each to allow the message to be sent. 

Code:

instructions for use 

			
Option Compare Database 
Option Explicit 
 
Dim mstrNotSent As String 
Dim mstrEmailInvalid As String 
 
Const mcn_strMODULE = "frm_MergeToOutlook" 
 
Private Sub cmdMerge_Click() 
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     ' Purpose:      Merge data to Word then email via Outlook
     ' Restrictions: Required information:
     '                   - Name of data source (table or query)
     '                   - Name of field containing email address
     '                   - Name of Word document to merge to
     '                   - Subject line of email
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     
    Const cn_strPROCEDURE = "cmdMerge_Click" 
     
     
     ' check required fields
    On Error Goto ErrHandler 
    If Nz(Me.lstDataSource, "") = "" Or _ 
    Me.lstDataSource = "<<<TABLES>>>" Or _ 
    Me.lstDataSource = "<<<QUERIES>>>" Then 
         
        MsgBox "You must select the table or query " & vbCrLf & _ 
        "to act as the data source for the mailmerge", vbInformation, _ 
        "No Data Source" 
         
    Else 
        If Nz(Me.lstEmailField, "") = "" Then 
            MsgBox "You must select the name of field containing " & vbCrLf & _ 
            "the email address", vbInformation, "No Field Selected" 
             
        Else 
            If Nz(Me.txtMergeDoc, "") = "" Then 
                MsgBox "You must select the Microsoft Word document " & vbCrLf & _ 
                "you want to merge to", vbInformation, "No Merge Document" 
                 
            Else 
                If Dir(Me.txtMergeDoc, vbNormal) = "" Then 
                    MsgBox "The Microsoft Word document cannot" & vbCrLf & _ 
                    "be found in this location.", vbInformation, _ 
                    "File Note Found" 
                     
                Else 
                    If Nz(Me.txtEmailSubject, "") = "" Then 
                        MsgBox "You must enter the Subject line of your email", _ 
                        vbInformation, "No Subject" 
                    Else 
                         ' perform mailmerge and email merged records
                         ' as attachments
                        If PerformMailMerge() = True Then 
                            If mstrNotSent <> "" Then 
                                MsgBox "Your mailmerge was NOT successful." & _ 
                                vbCrLf & "The following emails received an error:" & _ 
                                vbCrLf & vbCrLf & mstrNotSent, vbExclamation, _ 
                                "Error Sending Emails" 
                            Else 
                                If mstrEmailInvalid <> "" Then 
                                    MsgBox "Your mailmerge is completed and has been " & _ 
                                    vbCrLf & "emailed, with the exception of the " & _ 
                                    "following recipients:" & vbCrLf & vbCrLf & _ 
                                    mstrEmailInvalid & vbCrLf & "Please check that " & _ 
                                    "these email addresses are valid.", vbInformation, _ 
                                    "Mailmerge Complete with Exceptions" 
                                Else 
                                    MsgBox "Your mailmerge is completed and has been " & _ 
                                    vbCrLf & "emailed to all recipients", vbInformation, _ 
                                    "Mailmerge Complete" 
                                End If 
                            End If 
                             
                        Else 
                            MsgBox "Your mailmerge was NOT successful." & _ 
                            vbCrLf & "Please check the Send Items in Outlook" & _ 
                            vbCrLf & "to check which emails have been sent.", _ 
                            vbExclamation, "Mailmerge NOT Completed" 
                        End If 
                    End If 
                End If 
            End If 
        End If 
    End If 
     
     
ExitHere: 
    DoCmd.Hourglass False 
    Exit Sub 
     
ErrHandler: 
    MsgBox Err.Number & ": " & Err.Description, vbCritical, _ 
    "Unexpected Error in " & mcn_strMODULE & "." & cn_strPROCEDURE 
    Resume ExitHere 
End Sub 
 
Private Sub cmdOpenDoc_Click() 
    Me.txtMergeDoc = GetOpenFile(GetDefaultPath(), "Select Word document for mail merge") 
End Sub 
 
Private Sub Form_Load() 
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     ' Purpose:      Capture a list of all tables and queries (except system)
     '               from the database
     ' Restrictions: Requires reference to DAO object library
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     
    Dim db As DAO.Database 
    Dim tdf As DAO.TableDef 
    Dim qdf As DAO.QueryDef 
     
    Const cn_strPROCEDURE = "Form_Load" 
     
     
     ' create a divider between Tables and Queries in the list
    On Error Goto ErrHandler 
    Me.lstDataSource.RowSource = "<<<TABLES>>>;" 
     
    Set db = CurrentDb 
     
     ' add all tables (excluding system tables) to the list
    For Each tdf In db.TableDefs 
        If LCase(Left(tdf.Name, 4)) <> "msys" Then 
            Me.lstDataSource.RowSource = Me.lstDataSource.RowSource & tdf.Name & ";" 
        End If 
    Next tdf 
     
     ' create a divider between Tables and Queries in the list
    Me.lstDataSource.RowSource = Me.lstDataSource.RowSource & "<<<QUERIES>>>;" 
     
     ' add all tables (excluding system tables) to the list
    For Each qdf In db.QueryDefs 
        If Left(qdf.Name, 1) <> "~" Then 
            Me.lstDataSource.RowSource = Me.lstDataSource.RowSource & qdf.Name & ";" 
        End If 
    Next qdf 
     
     
ExitHere: 
    On Error Resume Next 
    qdf.Close 
    db.Close 
     
    Set tdf = Nothing 
    Set qdf = Nothing 
    Set db = Nothing 
    Exit Sub 
     
ErrHandler: 
    MsgBox Err.Number & ": " & Err.Description, vbCritical, _ 
    "Unexpected Error in " & mcn_strMODULE & "." & cn_strPROCEDURE 
    Resume ExitHere 
End Sub 
 
Private Sub cmdClose_Click() 
    On Error Goto Err_cmdClose_Click 
     
     
    DoCmd.Close 
     
Exit_cmdClose_Click: 
    Exit Sub 
     
Err_cmdClose_Click: 
    MsgBox Err.Description 
    Resume Exit_cmdClose_Click 
     
End Sub 
 
Private Sub lstDataSource_Click() 
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     ' Purpose:      Capture a list of all fields in the selected table/query
     ' Restrictions: Requires reference to DAO object library
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Dim db As DAO.Database 
    Dim tdf As DAO.TableDef 
    Dim qdf As DAO.QueryDef 
    Dim fld As DAO.Field 
     
    Const cn_strPROCEDURE = "lstDataSource_Click" 
     
     
    Me.lstEmailField.RowSource = "" 
     
     ' must have a table or query selected
    On Error Goto ErrHandler 
    Select Case Nz(Me.lstDataSource, "") 
    Case "", "<<<TABLES>>>", "<<<QUERIES>>>" 
         
    Case Else 
         ' capture field names
        Set db = CurrentDb 
         
        On Error Resume Next 
        Set tdf = db.TableDefs(Me.lstDataSource) 
         
        If Err.Number = 0 Then 
            On Error Goto ErrHandler 
            For Each fld In tdf.Fields 
                Me.lstEmailField.RowSource = Me.lstEmailField.RowSource & fld.Name & ";" 
            Next fld 
             
        Else 
            On Error Goto ErrHandler 
            Set qdf = db.QueryDefs(Me.lstDataSource) 
             
            For Each fld In qdf.Fields 
                Me.lstEmailField.RowSource = Me.lstEmailField.RowSource & fld.Name & ";" 
            Next fld 
        End If 
    End Select 
     
     
ExitHere: 
    On Error Resume Next 
    qdf.Close 
    db.Close 
     
    Set fld = Nothing 
    Set tdf = Nothing 
    Set qdf = Nothing 
    Set db = Nothing 
    Exit Sub 
     
ErrHandler: 
    MsgBox Err.Number & ": " & Err.Description, vbCritical, _ 
    "Unexpected Error in " & mcn_strMODULE & "." & cn_strPROCEDURE 
    Resume ExitHere 
End Sub 
 
Function PerformMailMerge() As Boolean 
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     ' Purpose:      Merge individual letter to Word
     ' Restrictions: Requires reference to MS Word Object Library
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     
    Dim objWord As Word.Application 
    Dim db As DAO.Database 
    Dim rec As DAO.Recordset 
    Dim strSQL As String 
    Dim strMergeDoc As String 
     
    Const cn_strPROCEDURE = "PerformMailMerge" 
     
     
     ' as merged documents are to be emailed, select all records
     ' from nominated table/query where the email address field
     ' is not blank
    DoCmd.Hourglass True 
    On Error Goto ErrHandler 
    strSQL = "SELECT * " & _ 
    "FROM   [" & Me.lstDataSource & "] " & _ 
    "WHERE  [" & Me.lstEmailField & "] Is Not Null" 
     
    Set db = CurrentDb 
    Set rec = db.OpenRecordset(strSQL, dbOpenSnapshot) 
    strMergeDoc = Me.txtMergeDoc 
     
    If Not rec.EOF Then 
        Set objWord = CreateObject("Word.Application") 
         
        With objWord 
            .Documents.Open strMergeDoc 
             
            With .ActiveDocument.MailMerge 
                 ' create link to data source
                .OpenDataSource Name:=db.Name, LinkToSource:=True, _ 
                Connection:="TABLE " & Me.lstDataSource, SQLStatement:= _ 
                strSQL 
                 
                .Destination = wdSendToNewDocument 
                .SuppressBlankLines = True 
                 
                Do Until rec.EOF 
                    With .DataSource 
                         ' merge one at a time in order to email separate
                         ' attachments
                        .QueryString = strSQL & " AND [" & Me.lstEmailField & "] =" & _ 
                        Chr(34) & rec(Me.lstEmailField) & Chr(34) 
                        .FirstRecord = wdDefaultFirstRecord 
                        .LastRecord = wdDefaultLastRecord 
                    End With 
                     
                    .Execute Pause:=True 
                     
                     ' email the merged document
                    SendMergeEmail objWord, strMergeDoc, rec(Me.lstEmailField) 
                     
                    objWord.Windows(strMergeDoc).Activate 
                     
                    rec.MoveNext 
                Loop 
            End With 
             
            .Windows(strMergeDoc).Activate 
            .ActiveDocument.Close False 
            .Quit 
        End With 
    End If 
     
    PerformMailMerge = True 
     
     
ExitHere: 
    On Error Resume Next 
    rec.Close 
    db.Close 
     
    Set rec = Nothing 
    Set db = Nothing 
    Set objWord = Nothing 
    Exit Function 
     
ErrHandler: 
    MsgBox Err.Number & ": " & Err.Description, vbCritical, _ 
    "Unexpected Error in " & mcn_strMODULE & "." & cn_strPROCEDURE 
    Resume ExitHere 
End Function 
 
Sub SendMergeEmail(objWord As Word.Application, strMergeDoc As String, _ 
    strTo As String) 
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     ' Purpose:      Send current document as email attachment
     ' Outputs:      Updates module-level variable mstrNotSent with the
     '               email address of all messages that failed
     ' Restrictions: Requires reference to MS Word Object Library
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Dim objOL As Outlook.Application 
    Dim objML As Outlook.MailItem 
    Dim strPath As String 
     
    Const cn_strPROCEDURE = "SendMergeEmail" 
     
     
    On Error Goto ErrHandler 
    strMergeDoc = Mid(strMergeDoc, InStrRev(strMergeDoc, "\") + 1) 
     
     ' remove all links to the database and save as a temporary file
    With objWord 
        .DisplayAlerts = wdAlertsNone 
        .ActiveDocument.MailMerge.MainDocumentType = wdNotAMergeDocument 
        .ActiveDocument.SaveAs GetDefaultPath() & "t" & strMergeDoc 
        .DisplayAlerts = wdAlertsAll 
         
        .ActiveDocument.Close 
    End With 
     
    On Error Resume Next 
    Set objOL = GetObject("", "Outlook.Application") 
     
    If Err.Number <> 0 Then 
        Set objOL = CreateObject("Outlook.Application") 
    End If 
     
    On Error Goto ErrHandler 
    Set objML = objOL.CreateItem(olMailItem) 
     
    With objML 
        .To = strTo 
         
         ' only process if email address is valid
        If .Recipients.ResolveAll = True Then 
            .Subject = Me.txtEmailSubject 
            .Attachments.Add GetDefaultPath() & "t" & strMergeDoc 
            .ReadReceiptRequested = Me.chkReadReceipt 
            .OriginatorDeliveryReportRequested = Me.chkDeliveryReceipt 
             
            Select Case Me.cboImportance 
            Case 1: .Importance = olImportanceHigh 
            Case 2: .Importance = olImportanceNormal 
            Case 3: .Importance = olImportanceLow 
            End Select 
             
            If Me.chkDisplay = True Then 
                .Display 
            Else 
                .Send 
            End If 
             
        Else 
             ' discard the email and note the unsuccessful address
            mstrEmailInvalid = mstrEmailInvalid & vbTab & strTo & vbCrLf 
             
            .Close (olDiscard) 
        End If 
    End With 
     
     ' delete temporary file
    On Error Resume Next 
    Kill GetDefaultPath() & "t" & strMergeDoc 
     
     
ExitHere: 
    On Error Resume Next 
    Set objML = Nothing 
    Set objOL = Nothing 
    Exit Sub 
     
ErrHandler: 
    MsgBox Err.Number & ": " & Err.Description, vbCritical, _ 
    "Unexpected Error in " & mcn_strMODULE & "." & cn_strPROCEDURE 
    mstrNotSent = mstrNotSent & vbTab & strTo & vbCrLf 
    Resume ExitHere 
End Sub 
 
Function GetDefaultPath() As String 
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     ' Purpose:      Capture the database path
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    GetDefaultPath = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) 
End Function

How to use:

  1. Open your database
  2. Select File | Get External Data | Import
  3. Go to the Forms tab
  4. Click on "frm_MergeToOutlook"
  5. Go to the Modules tab
  6. Click on "mod_OpenFileDialog"
  7. Select OK
  8. Go to the Modules tab
  9. Click on "mod_OpenFileDialog"
  10. Select Design
  11. Select Tools | References
  12. Add a reference to "Microsoft Word Object Library" (select your current version)
  13. Add a reference to "Microsoft DAO 3.6 Object Library"
  14. Add a reference to "Microsoft Outlook Object Library" (select your current version)
  15. Select File | Close and return to Microsoft Access
 

Test the code:

  1. Open the form "frm_MergeToOutlook"
  2. Check that all the tables and queries in your database are listed down the left
  3. Click on the table or query you want to use for your mailmerge (for testing purposes it's best to use a table or query that does not contain a lot of records)
  4. Check that all the fields in that table or query are listed on the right
  5. Click on the field that contains the email address
  6. Click on "Select Merge Document"
  7. Navigate to a Word document that you want to send to all the nominated people, then select OK
  8. Type the Email Subject Line
  9. Select the mail options you would like (for testing purposes, make sure "Display Email prior to sending" is selected)
  10. Select Run Merge
 

Sample File:

MergeToOutlook.zip 76.71KB 

Approved by mdmackillop


This entry has been viewed 104 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2012 VBA Express