Export any SQL to a mailmerge document - as painless as possible

[psemianonymous]

So a lot of us don't use mailmerge, partially because it's so painful to do so. You have to 1) make a query, 2) make the mailmerge document point back to that query, 3) allow for Word to seperately open that query everytime mailmerge is run, which may or may not open another Access application in the process. Sending multiple mailmerges in this way can be painful past the point of frustration.

Enter my solution. It requires that you have 1) a working text export specification, 2) a sample text file containing data using those specific fields. That is all.


The single entry point for this code module is RunMailmerge. You pass in the SQL, you pass in the text export specification, and you pass in the destination document file. Currently it is programmed to look for the destination document in a subdirectory of your database backend, but you can redefine this quite easily (just change the GetStartDirectory() function to whatever, or eliminate it completely).


Basically, this enables you to pass in a very complicated SQL SELECT statement, with any number of 'parameters', and then opens the mailmerge document like any internal Access report.

Additionally, I've tried my hardest to cover every possible error, including empty recordsets, missing mailmerge files, etc, and gracefully retreating when such an error occurs, thus leaving no footprint. This process should be transparent, as I programmed it to be.

This code has been in production for over a week now with no errors. I was going to wait longer, but since someone asked for this specific type of solution, I decided to post it now. I was having trouble with an earlier version of this, but those issues have been resolved. So.

Use/abuse/let me know if anything goes wrong.


Pete

'basExportSQL -
'feel free to modify, rewrite, and generally claim 
'that this is your own.
'
'Pete

Option Compare Database
Option Explicit

'these are the listing of the export specifications.
Public Const trnExDmLicense As String = "exExample1"
Public Const trnExDmTraining As String = "exExample2"


Public Sub RunMailmerge(SQL As String, ExportSpecificationName As String, MergeDocumentFilename As String)
On Error GoTo Sub_Error
    Dim objWordDoc As Object
    Dim strMailmergeDataFilename As String
    
    
    strMailmergeDataFilename = GetStartDirectory() & Year(DATE) & "_" & Month(DATE) & "_" & Day(DATE) & "_" & Hour(Now) & "_" & Minute(Now) & "_" & Second(Now) & ".txt"
    
    ExportSqlSelectStatementToCsv SQL, ExportSpecificationName, strMailmergeDataFilename
    
    Set objWordDoc = GetObject(GetStartDirectory() & 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
    objWordDoc.Close SaveChanges:=0 '0 = wdDoNotSaveChanges
    
    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 " & _
        "'" & GetStartDirectory() & MergeDocumentFilename & "'."
    Else
        MsgBox Err.Description
    End If
    Resume Sub_Exit
End Sub



Public Sub ExportSqlSelectStatementToCsv(SQL As String, ExportSpecificationName 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_" & Year(DATE) & "_" & Month(DATE) & "_" & Day(DATE) & "_" & Hour(Now) & "_" & Minute(Now) & "_" & Second(Now)

    Set db = CurrentDb
    Set qdf = db.CreateQueryDef(strQdfName, SQL)
    Set qdf = Nothing
    Set db = Nothing
    
    If Nz(DCount("*", strQdfName), 0) <= 0 Then
        On Error GoTo 0
        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, ExportSpecificationName, 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
        Err.Clear
        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."
        Resume Sub_Exit
    End If
End Sub



Private Function GetStartDirectory() As String
    GetStartDirectory = CurrentBackendPath() & "mm\"
End Function


Private Function CurrentBackendPath() As String
Const JETDBPrefix As String = ";DATABASE="
Const strTableName As String = "GLOBALS"

    Dim str As String
    Dim idx As Integer
    
    str = CurrentDb().TableDefs(strTableName).Connect
    idx = InStr(1, str, JETDBPrefix, vbTextCompare)
    str = Mid(str, idx + Len(JETDBPrefix))
    CurrentBackendPath = GetPath(str)
End Function


Private Function GetPath(filename As String)
    If Dir(filename) = "" Then
        GetPath = ""
    Else
        GetPath = Left(filename, Len(filename) - Len(Dir(filename)))
    End If
End Function