Option Compare Database
Option Explicit

Function OpenWordDocument(strQuery As String, fChoose As Boolean, Optional strWordFile As String) As Boolean
   ' Comments   : Opens specific Word document for mail merging
   ' Parameters : strQuery - indicates the query to be used for the merge
   '              fChoose - indicates if user will browse for word file or if one has been specified
   '              strWordFile - name of the file to open
   ' Returns    : Boolean
   
   ERH_PushStack_TSB ("OpenWordDocument")
   On Error GoTo OpenWordDocument_ERR
   
   Dim objWord As Object
   Dim strDialogTitle As String
   Dim strPath As String
   Dim strFileFilter As String
   Dim strMergeFilePath As String
   Dim strDocFile As String
   
   strPath = GetCurrentPath_TSB()
   strMergeFilePath = strPath & "MergeData.txt"
   Call CreateMergeDataSource(strQuery, strMergeFilePath)
   'let user pick merge file
   If fChoose = True Then
      strDialogTitle = "Find the MS Word Merge Document"
      strFileFilter = "Word Documents or Templates (*.doc;*.dot)|*.doc;*.dot"
      DoCmd.Echo False, "Retrieving Word Document..."
      DoCmd.Hourglass False
      strDocFile = OpenFiles(strDialogTitle, strPath, strFileFilter)
      DoCmd.Hourglass True
   Else
      strDocFile = strPath & strWordFile
   End If
   If strDocFile = "" Then
      'User pressed Cancel
      OpenWordDocument = False
      GoTo OpenWordDocument_EXIT
   End If
   Set objWord = GetObject(strDocFile, "Word.Document")
   ' Make Word visible
   With objWord
      .Application.Visible = True
      'Execute the mail merge
      .MailMerge.ViewMailMergeFieldCodes = True
      .MailMerge.Execute
   End With
   
   OpenWordDocument = True
   
   Set objWord = Nothing
   
OpenWordDocument_EXIT:
   ERH_PopStack_TSB
   Exit Function
   
OpenWordDocument_ERR:
   ERH_Handler_TSB
   Exit Function
   
End Function

Private Sub CreateMergeDataSource(ByVal strTblQry As String, ByVal strFilePath As String)
   ' Comments   : Creates a text file for merge purposes - code source: Bret Barabash
   ' Parameters : strTblQry - Query or Table to use for producing mail merge file
   '              strFilePath - path to folder to create the file in
   ' Returns    : Boolean -
   
   ERH_PushStack_TSB ("CreateMergeDataSource")
   On Error GoTo CreateMergeDataSource_ERR
   
   'use delimiters that won't be used in a normal Word document
   Const cFieldDelim = "~"
   Const cRecordDelim = "^"
   
   Dim db As DAO.Database
   Dim rs As DAO.Recordset
   Dim fld As DAO.Field
   Dim lngFileNo As Long
   Dim strBuffer As String
   
   Set db = CurrentDb()
   Set rs = db.OpenRecordset(strTblQry, dbOpenSnapshot)
   
   'Initialize field name list (first line of data source)
   For Each fld In rs.Fields
      Select Case fld.Type
         Case dbGUID, dbLongBinary, dbMemo
            'Do not include these types of fields
         Case Else
            strBuffer = strBuffer & Chr$(34) & fld.Name & Chr$(34) & cFieldDelim
      End Select
   Next fld
   strBuffer = strBuffer & cRecordDelim
   
   'Loop through all records in source table/query
   Do Until rs.EOF
      For Each fld In rs.Fields
         DoCmd.Hourglass True
         Select Case fld.Type
            Case dbGUID, dbLongBinary, dbMemo
               'Do not include these types of fields
            Case Else
               strBuffer = strBuffer & Chr$(34) & fld.Value & Chr$(34) & cFieldDelim
         End Select
         DoCmd.Hourglass False
      Next fld
      strBuffer = strBuffer & cRecordDelim
      rs.MoveNext
   Loop
   rs.Close
   
   'Generate data source text file
   lngFileNo = FreeFile
   Open strFilePath For Output As #lngFileNo
   Print #lngFileNo, strBuffer
   Close #lngFileNo
   
   Set rs = Nothing
   Set db = Nothing
   
CreateMergeDataSource_EXIT:
   ERH_PopStack_TSB
   Exit Sub
   
CreateMergeDataSource_ERR:
   ERH_Handler_TSB
   Exit Sub
   
End Sub