Option Compare Database
Option Explicit
Public Sub RunMailmerge(SQL As String, Optional MergeTemplate As String = "")
'MergeTemplate is the full path and name of a Word template file (.dot)
On Error GoTo Sub_Error
Dim objWordDoc As Object 'Word.Document
Dim strMailmergeDataFilename As String
Dim strMergeDocumentFilename As String
Dim strSaveDirectory As String
Dim fs
'The name of the folder where the files will be created. This folder
'will be created if it does not exist.
strSaveDirectory = CurrentProject.Path & "\WordFiles\"
'The name of the file to hold the data (.txt) and the nanme of the
'merge document (.doc)
strMailmergeDataFilename = strSaveDirectory & Format(Now, "yymmdd_hhnnss") & ".txt"
strMergeDocumentFilename = strSaveDirectory & Format(Now, "yymmdd_hhnnss") & ".doc"
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(strSaveDirectory) Then
fs.CreateFolder (strSaveDirectory)
End If
'Export the query to a CSV, see code below
If ExportSQLToCSV(SQL, strMailmergeDataFilename) <> True Then
GoTo Sub_Exit
End If
If MergeTemplate <> "" Then
'If a template has been supplied, get a Word document
'using that template ...
Set objWordDoc = GetObject(MergeTemplate, "Word.Document")
Else
'Otherwise, just get a Word document
Set objWordDoc = GetObject("", "Word.Document")
End If
'Make it visible.
objWordDoc.Application.Visible = True
'Open the data source, ie the .txt file
'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:=""
'PSeale's code is nicely general and can be used anywhere, the code below cannot.
'It assumes that you are building a letter and that the letter contains certain fields
'It is not needed, if you supply a template (.dot) and from this comment to "****END"
'it can be deleted or editied to show the fields in your query.
If MergeTemplate = "" Then
With objWordDoc.Application
.Selection.TypeText Text:=vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf
.Selection.TypeText Text:=Format(Date, "Long Date")
.Selection.TypeText Text:=vbCrLf & vbCrLf
.ActiveDocument.Mailmerge.EditMainDocument
.ActiveDocument.Mailmerge.Fields.Add Range:=.Selection.Range, Name:="Contact"
.Selection.TypeParagraph
.ActiveDocument.Mailmerge.Fields.Add Range:=.Selection.Range, Name:="Company"
.Selection.TypeParagraph
.ActiveDocument.Mailmerge.Fields.Add Range:=.Selection.Range, Name:="Address"
.Selection.TypeParagraph
.Selection.TypeParagraph
.Selection.TypeText Text:="Dear "
.ActiveDocument.Mailmerge.Fields.Add Range:=.Selection.Range, Name:="Dear"
End With
End If
'****END
'Uncomment the next two lines if you want the mailmerge to run automatically
'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:
MsgBox Err.Description
Resume Sub_Exit
End Sub
Function ExportSQLToCSV(SQL As String, FullPathAndFilename As String) As Boolean
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 strErrMessage As String
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
ExportSQLToCSV = False
strQDFName = "~temp_mailmerge_" & Format(Now, "yymmdd_hhnnss")
Set db = CurrentDb
Set qdf = db.CreateQueryDef(strQDFName, SQL)
Set qdf = Nothing
Set db = Nothing
If DCount("*", strQDFName) <= 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
strErrMessage = "The report has no data, and thus cannot properly merge."
Err.Raise vbObjectError + 1024 + 2, "Query Export to CSV", strErrMessage
End If
AttemptToDeleteFile FullPathAndFilename
DoCmd.TransferText acExportDelim, , strQDFName, FullPathAndFilename, True
If Dir(FullPathAndFilename) <> "" Then ExportSQLToCSV = True
Sub_Exit:
On Error Resume Next
CurrentDb.QueryDefs.Delete strQDFName
Exit Function
Sub_Error:
MsgBox Err.Description
Resume Sub_Exit
End Function
'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
However, the advantage of Word is that users get to mess around, which is something users usually like to do.
