Private Sub cmdSummit_Click()
Dim db As DAO.Database
'define query object perameter
Dim qry As DAO.QueryDef
Dim i As Integer
Dim rsMailmerge As Recordset
Dim strTextFile As String
Dim strTemplatePath As String
Dim strSavePath As String
Dim strSaveName As String
Me.txtHidden.SetFocus
strTemplatePath = "L:\Access Databases\Group Manufacturing\Mortgages Direct\Academy\ADFE\Files\T&C Templates\QA Forms\"
strSavePath = DLookup("Variable", "tblVariable", "VariableID=16")
strSaveName = "Health Check Form " & Format(Now(), "yyyymmmdd_hhmmss") & " " & Me.cboAgent.Column(1) & ".doc"
'set current datedate as database objects
Set db = CurrentDb
'set your record set using reference from the form
Set rsMailmerge = db.OpenRecordset("SELECT * FROM tblQA WHERE [QAID] =" & Me.QAID)
'Call GetWordHandle
'function that opens word to run in the background, function can be placed in a global module
If WordApp Is Nothing Then ' if word not called before
Err.clear ' Clear Err object in case error occurred.
Set WordApp = CreateObject("Word.Application") 'Start a new word application
Else
' an instance of word has been created before
On Error Resume Next 'Turn off error handling
Err.clear ' Clear Err object in case error occurred.
WordApp.Visible = False 'attempt to access previous instance of word
If Err.Number <> 0 Then ' if instance of word no longer exists then create a new one
Err.clear ' Clear Err object
Set WordApp = CreateObject("Word.Application") 'Start a new word application
On Error GoTo 0 'Revert to normal error handling
End If
End If
'Hide word (it will be made visible again CloseOrEditDocument or if an error occurs)
WordApp.Visible = False
WordApp.WindowState = 2
WordApp.Visible = False
'next we are going to create a text file that that the word template will merge with
'_________________________________________________________________________________________
'text file file name
strTextFile = "HealthCheck_" & Format(Now(), "yyyymmdd_hhnnss")
'function that creates and saves the text file
createKFIMailMergefile strPath, strTextFile & ".txt"
'open template
Set WordDoc = WordApp.Documents.Open(strTemplatePath & "Health Check Form.dot")
'merge template with txt file
WordDoc.MailMerge.MainDocumentType = 0
WordDoc.MailMerge.Destination = wdSendToNewDocument
WordDoc.MailMerge.OpenDataSource (strPath & strTextFile & ".txt")
WordDoc.MailMerge.Execute
'Go through all created doc and remove all mail merge errors
For i = 1 To WordApp.Application.Documents.Count
If InStr(1, WordApp.Application.Documents(i).Name, "Error") <> 0 Then
WordApp.Application.Documents.Item(i).Close False
i = i - 1
End If
If i = WordApp.Application.Documents.Count Then Exit For
Next i
'Save merged document as new file
WordApp.ActiveDocument.AttachedTemplate.Saved = True
WordDoc.Application.Documents.Item(1).SaveAs strSavePath & strSaveName, , , , False, , True
'Go through all created doc and close them
For i = 1 To WordApp.Application.Documents.Count
WordApp.Application.Documents.Item(WordApp.Application.Documents.Count).Close False
Next i
'WordDoc.Close
'WordApp.Quit
'delete the text file
Kill strPath & strTextFile & ".txt"
'delete the subs
exithere:
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
Set qry = Nothing
Set db = Nothing
MsgBox ("Export Completed")
'MergePCACallData
Application.FollowHyperlink strSavePath & strSaveName
Exit Sub
exporterror:
Resume exithere
End Sub
