Unable to Send Word Mail Merge Email in VBA Due to Word File not Opening-CodePudding

I have a table in access and a Word mail merge setup and linked to the table. I would like my customers to receive an email on a specific date stated in the table. I have created a template in word and started the mail merge process using the step-by-step mail merge wizard ready for VBA to send the email. I have tried this VBA code in Access, but it just keeps crashing and I think it is because it can't open the Word file. I am sure of this as I commented out the code line by line and it only crashed when I put Set wdDoc = wdApp.Documents.Open("C:\Users\Adam Khattab\Documents\Mail Merge - Copy.docx"). I reviewed this this post, however, this is specifically for Access and not Excel.

Option Compare Database

Sub SendEmailsWord()

Const wdSendToEmail As Long = 0

Const wdMailFormatPlainText As Long = 2

On Error GoTo ErrorHandler

'Declare variables

Dim wdApp As Word.Application

Dim wdDoc As Word.Document

Dim strSQL As String

Dim rst As DAO.Recordset

'Set the reference to the Word application

On Error Resume Next

Set wdApp = GetObject(, "Word.Application")

On Error GoTo 0

If wdApp Is Nothing Then

  Set wdApp = CreateObject("Word.Application")

End If

'Open the mail merge document

Set wdDoc = wdApp.Documents.Open("C:\Users\Adam Khattab\Documents\Mail Merge - Copy.docx")

'Set the reference to the recordset

strSQL = "SELECT * FROM CustomerBookingTBL WHERE EmailAddress IS NOT NULL"

Set rst = CurrentDb.OpenRecordset(strSQL)

'Start the mail merge

wdDoc.MailMerge.OpenDataSource "C:\Users\Adam Khattab\Documents\Customer_Bookings_Backup.accdb", strSQL

'Loop through the recordset and send each email

Do Until rst.EOF

    wdDoc.MailMerge.Destination = wdSendToEmail

    wdDoc.MailMerge.SuppressBlankLines = True

    With wdDoc.MailMerge

        .MailFormat = wdMailFormatPlainText

        .MailSubject = "Mail Merge Subject"

        .MailAsAttachment = False

        .MailAddressFieldName = "EmailAddress"

        .Execute Pause:=False

    End With

    rst.MoveNext

Loop

'Close the mail merge document

wdDoc.Close False

'Close the Word application

wdApp.Quit

Exit Sub

ErrorHandler:

  MsgBox "An error occurred: " & Err.Description

End Sub

CodePudding user response：

If your Word document has been saved as a mailmerge main document (which seems to be the case), that would certainly cause your implementation to 'crash'. What happens is that, when the document gets opened, Word waits for the user to respond to the mailmerge SQL prompt one ordinarily sees with such documents. You need to disable that prompt. Hence, using early binding:

Sub SendEmailsWord()
Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String, strSQL As String
Dim wdApp As New Word.Application, wdDoc As Word.Document, Rst As DAO.Recordset
wdApp.Visible = False: wdApp.DisplayAlerts = wdAlertsNone
StrMMPath = "C:\Users\Adam Khattab\Documents\"
StrMMSrc = StrMMPath & "Customer_Bookings_Backup.accdb"
StrMMDoc = StrMMPath & "Mail Merge - Copy.docx"
strSQL = "SELECT * FROM CustomerBookingTBL WHERE EmailAddress IS NOT NULL"
Set Rst = CurrentDb.OpenRecordset(strSQL)
Set wdDoc = wdApp.Documents.Open(Filename:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
  With .MailMerge
    .MainDocumentType = wdEMail
    .OpenDataSource StrMMSrc, strSQL
    .SuppressBlankLines = True
    .MailAddressFieldName = "EmailAddress"
    .MailSubject = "Mail Merge Subject"
    .MailAsAttachment = False
    .MailFormat = wdMailFormatPlainText
    Do Until Rst.EOF
      .Execute Pause:=False
      Rst.MoveNext
    Loop
    .MainDocumentType = wdNotAMergeDocument
  End With
  .Close SaveChanges:=False
End With
wdApp.DisplayAlerts = wdAlertsAll: wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set Rst = Nothing
Application.ScreenUpdating = False
End Sub

CodePudding user response：

I have finally got it working. I had to use the OLEDB to connect to the database.

Option Compare Database
Option Explicit

Sub SendEmailsWord()

'Application.ScreenUpdating = False
Dim StrMMSrc As String, StrMMDoc As String, StrMMPath As String, StrName As String, strSQL As String
Dim wdApp As New Word.Application, wdDoc As Word.Document, Rst As DAO.Recordset
wdApp.Visible = True: wdApp.DisplayAlerts = wdAlertsNone: wdApp.WordBasic.DisableAutoMacros
StrMMPath = "C:\Users\Adam Khattab\Documents\"
StrMMSrc = StrMMPath & "Customer_Bookings_Backup.accdb"
StrMMDoc = StrMMPath & "mail_merge.docx"
'strSQL = "SELECT * FROM CustomerBookingTBL WHERE EmailAddress IS NOT NULL"
'Set Rst = CurrentDb.OpenRecordset(strSQL)
Set wdDoc = wdApp.Documents.Open(FileName:=StrMMDoc, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
  With .MailMerge
    .MainDocumentType = wdEMail
      .OpenDataSource Name:=StrMMSrc, ReadOnly:=True, AddToRecentFiles:=False, _
        LinkToSource:=False, Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
        "Data Source=StrMMSrc;Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
        SQLStatement:="SELECT * FROM `CustomerBookingTBL`", SubType:=wdMergeSubTypeAccess
        
    .MailAddressFieldName = "EmailAddress"
    .Destination = wdSendToEmail
    .MailSubject = "Mail Merge Subject"
    .MailAsAttachment = False
    .MailFormat = wdMailFormatPlainText
    .SuppressBlankLines = True
    With .DataSource
        .FirstRecord = wdDefaultFirstRecord
        .LastRecord = wdDefaultLastRecord
    'Do Until Rst.EOF
    '  .Execute Pause:=False
     ' Rst.MoveNext
    End With
      .Execute Pause:=False
    'Loop
    '.MainDocumentType = wdNotAMergeDocument
  End With
  .Close Savechanges:=False
End With
wdApp.DisplayAlerts = wdAlertsAll: wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set Rst = Nothing
'Application.ScreenUpdating = False
End Sub