[AccessD] Mail Merge

Rocky,
Here is code I use use for mail merging:

'Form code:
'----------
Private Sub cmdWordPersonLetter_Click()
   ' Comments   :  Opens PersonLetterMerge.dot Word document for doing a
envelope merge with individuals (not companies) 
   ' Source     :  WinHaven revised: 10/24/2003
   ' Parameters :  none
   ' Returns    :  none
   On Error GoTo cmdWordPersonLetter_Click_ERR  
   Dim fOk As Boolean
   DoCmd.Hourglass True
   DoCmd.Echo False, "Performing Mail Merge with Word Letter Document..."
   fOk = OpenWordDocument("qryPeopleForMerging", False,
"PersonLetterMerge.dot")
   DoCmd.Echo True, "Word Merge process complete."
   DoCmd.Hourglass False
cmdWordPersonLetter_Click_EXIT:
   Exit Sub   
cmdWordPersonLetter_Click_ERR:
   Exit Sub   
End Sub

'Module code:
'------------
Function OpenWordDocument(strQuery As String, fChoose As Boolean, Optional
strWordFile As String) As Boolean
   ' Comments   : Opens specific Word document for mail merging
   ' Source     : WinHaven revised: 10/24/2003
   ' 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 (to indicate results)
   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:
   Exit Function
OpenWordDocument_ERR:
   Exit Function
End Function

Private Sub CreateMergeDataSource(ByVal strTblQry As String, ByVal
strFilePath As String)
   ' Comments   : Creates a text file for merge purposes
   ' Source     : Bret Barabash - from AccessD
   ' Parameters : strTblQry - Query or Table to use for producing mail merge
file
   '              strFilePath - path and filename of the file to be created
   ' Returns    : Boolean (to indicate results)   
   On Error GoTo CreateMergeDataSource_ERR   
   'use delimiters that won't be used in a normal Word document
   Const cstrFieldDelim As String = "~"
   Const cstrRecordDelim As String = "^"
   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) &
cstrFieldDelim
      End Select
   Next fld
   strBuffer = strBuffer & cstrRecordDelim   
   '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) &
cstrFieldDelim
         End Select
         DoCmd.Hourglass False
      Next fld
      strBuffer = strBuffer & cstrRecordDelim
      rs.MoveNext
   Loop
   rs.Close   
   'Make sure there isn't already a file with the name of the merge file.
   If Dir(strFilePath) <> "" Then
      Kill strFilePath
   End If  
   '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:
   Exit Sub   
CreateMergeDataSource_ERR:
   Exit Sub   
End Sub

Function GetCurrentPath_TSB() As String
  ' Comments  : returns that path that the currently database is located in
  ' Source    : FMS Access Source Book '97
  ' Parameters: none
  ' Returns   : path of current database  '
  Dim dbsCurrent As Database
  Dim strTmp As String
  Dim strNew As String
  Dim intCounter As Integer
  Dim chrTmp As String * 1
  Dim fAdd As Boolean  
  Set dbsCurrent = CurrentDb()
  strTmp = dbsCurrent.Name  
  For intCounter = Len(strTmp) To 1 Step -1    
    chrTmp = Mid$(strTmp, intCounter, 1)    
    If chrTmp = "\" Then
      fAdd = True
    End If    
    If fAdd Then
      strNew = chrTmp & strNew
    End If    
  Next intCounter  
  GetCurrentPath_TSB = strNew    
End Function

Public Function OpenFiles(strTitle As String, strInitDir As String,
strFileType As String, Optional strDefaultExt As String, Optional
strDefaultFileName As String) As String
   ' Comments   : Opens the common dialog for finding a file
   ' Source     : WinHaven revised: 10/24/2003
   ' Parameters : strTitle=Title of Dialog Box
   '              strInitDir=Initial Directory to Open
   '              strFileType=Default File Type to Filter for
   '              strDefaultExt=default file extension to filter for
   '              strDefaultFileName=Default File Name to use
   ' Returns    : full path of file selected   
   On Error GoTo OpenFiles_ERR   
   'Open up a hidden form containing a common dialog control
   DoCmd.OpenForm "frmUtilityCommonDialog", WindowMode:=acHidden
   'Give the form time to load
   DoEvents
   'Set the properties of the Common dialog control
   If IsEmpty(strDefaultExt) Then
      strDefaultExt = ""
   End If
   If IsEmpty(strDefaultFileName) Then
      strDefaultFileName = ""
   End If   
   With Forms!frmUtilityCommonDialog!ctlComDialog
      .DialogTitle = strTitle
      .InitDir = strInitDir
      .Filter = strFileType
      .DefaultExt = strDefaultExt
      .CancelError = False
      .FileName = strDefaultFileName
      .Flags = OFN_LONGNAMES + OFN_HIDEREADONLY + OFN_FILEMUSTEXIST
   End With   
   'Invoke the File Open common dialog
   Forms!frmUtilityCommonDialog!ctlComDialog.ShowOpen
   'Store the name and location the user selected
   OpenFiles = Forms!frmUtilityCommonDialog!ctlComDialog.FileName   
OpenFiles_Exit:
   Exit Function   
OpenFiles_ERR:
   MsgBox "MsgBox 'Error in basWindowsCommonDialogs_WH - OpenFiles: ' &
Error$", vbOKOnly + vbExclamation, "System Information"
   Resume OpenFiles_Exit   
End Function