Public Sub RunMailmerge(SQL As String, MergeDocumentFilename As String)
On Error GoTo Sub_Error
Dim objWordDoc As Object
Dim strMailmergeDataFilename As String
Dim strDir As String
strDir = CurrentProject.Path & "\WordFiles\"
strMailmergeDataFilename = strDir & Format(Now, "yymmdd_hhnnss") & ".txt"
ExportSQLToCSV SQL, strMailmergeDataFilename
Set objWordDoc = GetObject(strDir & MergeDocumentFilename, "Word.Document")
objWordDoc.Application.Visible = True
'Format:=0 '0 = wdOpenFormatAuto
objWordDoc.MailMerge.OpenDataSource _
Name:=strMailmergeDataFilename, ConfirmConversions:=False, _
ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
WritePasswordTemplate:="", Revert:=False, Format:=0, _
Connection:="", SQLStatement:="", SQLStatement1:=""
'objWordDoc.MailMerge.Destination = 0 '0 = wdSendToNewDocument
'objWordDoc.MailMerge.Execute
Sub_Exit:
On Error Resume Next
'Word pops up a messagebox to confirm saving the document,
'even if specifically set it to "wdDoNotSaveChanges".
'Therefore first save the document, then close it.
'objWordDoc.Save
'objWordDoc.Close SaveChanges:=-1 '-1 = wdSaveChanges
Set objWordDoc = Nothing
'attempt to delete file, silently fail on errors.
'FileSystem.Kill strMailmergeDataFilename
Exit Sub
Sub_Error:
If Err.Number = 432 Then
MsgBox "ERROR: Invalid filename provided: '" & strMailmergeDataFilename & "' or " & _
"'" & strDir & MergeDocumentFilename & "'."
Else
MsgBox Err.Description
End If
Resume Sub_Exit
End Sub
Public Sub ExportSQLToCSV(SQL As String, FullPathAndFilename As String)
On Error GoTo Sub_Error
'steps:
'-create a new querydef with the SQL parameter as its SQL.
'save & attach this querydef.
'run the TransferText on this temp querydef,
'delete the querydef
Dim strQdfName As String
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
strQdfName = "~temp_mailmerge_" & Format(Now, "yymmdd_hhnnss")
Set db = CurrentDb
Set qdf = db.CreateQueryDef(strQdfName, SQL)
Set qdf = Nothing
Set db = Nothing
If Nz(DCount("*", strQdfName), 0) <= 0 Then
'in this case, if the query is empty/contains no entries, we
'should pop up a custom error message. Basically we shouldn't attempt to
'run the mailmerge if there's no data anyway, right?
'So we have to turn off the standard error handling, delete the query (otherwise
'the query is not deleted), and raise the error.
'
'the calling function "RunMailmerge" will catch and handle the error, and then
'gracefully exit.
On Error GoTo 0
CurrentDb.QueryDefs.Delete strQdfName
Err.Raise vbObjectError + 1024 + 2, "Query Export to CSV", "The report has no data, and thus cannot properly merge."
End If
AttemptToDeleteFile FullPathAndFilename
DoCmd.TransferText acExportDelim, , strQdfName, FullPathAndFilename, True
Sub_Exit:
On Error Resume Next
CurrentDb.QueryDefs.Delete strQdfName
Exit Sub
Sub_Error:
MsgBox Err.Description
Resume Sub_Exit
End Sub
'AttemptToDeleteFile -
'attempts to delete the mailmerge.txt file located in the database directory.
'Basically provides error-handling capabilities to the single "Kill" method call.
Private Sub AttemptToDeleteFile(strFilename As String)
On Error GoTo Sub_Error
Kill strFilename
Sub_Exit:
Exit Sub
Sub_Error:
If Err.Number = 53 Then 'err 53 = file not found, that means the file is already deleted!
'no error, continue
Resume Sub_Exit
ElseIf MsgBox("Cannot delete file. Close all Word mailmerge documents and click Retry.", vbRetryCancel + vbExclamation, "File In Use") = vbRetry Then
Resume
Else
On Error GoTo 0
Err.Raise vbObjectError + 1024 + 1, "file in use", "File In Use@" & _
"Cannot complete the mailmerge process because the file '" & strFilename & "' " & _
"is in use. Close all Word mailmerge documents and try again."
End If
End Sub
