Ok. Not sure what's going on here. I'm trying to initiate a mailmerge from Access VBA and when the Word mailmerge document is opened, the user get's asked to choose the query for the mailmerge, even though the connection is set in VBA and is attached as a source in the word document. Here's the code:
Code:
Response = MsgBox("Would you like to email the coordinator with the final thank you?", vbYesNo, "Final Survey Thank You?")
'need to add something if No selected saying tbl3Notifications.ClassFormReceived will not be updated
If Response = vbYes Then
DoCmd.OpenQuery "qry_FinalSurveyTY", , acEdit
'Code to open a word document.
Dim LWordDoc As String
Dim oApp As Object
Dim Email As String
Dim MyRs As Recordset
Dim EmailSubject As String
Dim ConsentPth As String
Dim myItem As Outlook.Attachments
Set MyRs = db.OpenRecordset("qry_FinalSurveyTY")
If (MyRs.RecordCount = 0) Then
MsgBox "No records in Query", vbOKOnly, "No Records"
Exit Sub
Else
MyRs.MoveFirst
'Path to the word document
Set recb = db.OpenRecordset("SELECT * FROM tbl_Classrooms WHERE SchoolID = " & Company_ID)
If recb("Survey_Type") = 2 Then
LWordDoc = "O:\PNA\2018 PNA\Correspondence\Surveys Returned Thank You - Online.docx"
ElseIf recb("Survey_Type") = 1 Then
LWordDoc = "O:\PNA\2018 PNA\Correspondence\Surveys Returned Thank You - Paper.docx"
End If
If Dir(LWordDoc) = "" Then
MsgBox "Document not found."
Else
'Create an instance of MS Word
On Error Resume Next
Set oApp = GetObject(LWordDoc, "Word.Application")
If Err.Number <> 0 Then
Set oApp = CreateObject(Class:="Word.Application")
'Open the Document
oApp.Documents.Open FileName:=LWordDoc
End If
On Error GoTo 0
With oApp
.Visible = True
'Open the Document
'oApp.Documents.Open FileName:=LWordDoc
With oApp.ActiveDocument.MailMerge
' .MainDocumentType = wdLetter
.OpenDataSource Name:="O:\PNA\Database\Recruitment Database.accdb", ConfirmConversions:=False, _
ReadOnly:=False, LinkToSource:=True, Connection:="QUERY qry_FinalSurveyTY"
.Destination = wdSendToNewDocument
.Execute
'.Close wdDoNotSaveChanges
'.Quit SaveChanges:=False
End With
'oApp.ActiveDocument.Close wdDoNotSaveChanges
End With
Set objOutlook = CreateObject("Outlook.Application")
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
Set myAttachments = objOutlookMsg.Attachments
Email = MyRs![EmailAddress]
EmailSubject = MyRs![Email_Subject]
CC = MyRs![ccEmail]
'ConsentPth = MyRs![ConsentPth]
With objOutlookMsg
.Display
.To = Email
.CC = CC
.Subject = EmailSubject
.Body = oApp.ActiveDocument.Content
'.Attachments.Add "Add any attachment paths here"
'.Send
End With
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End If
End If
rec.Edit
rec("FinalThankYou") = True
rec.Update
DoCmd.Close acQuery, "qry_FinalSurveyTY"
With oApp
.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
End With
Set rec = Nothing
Set recb = Nothing
Set db = Nothing
Set oApp = Nothing
End If