code: WriteToWord

attached is an example of a Word Document Template (WriteToWord.DOT) and an Access Database (WriteToWord.mdb) with code to use it

~~~~~~~~~~~~~ DOT

The template has 2 bookmarks: Firstname and Lastname.  They follow the prompts for the same information.

To see where the bookmarks are:

1. make a new document based on the template (or just open the template directly)

2. press GTRL-G (Goto)

3. from the 'Go to What' listbox, choose --> bookmark

4. on the right, drop the combobox to see the bookmarks that are defined

The code is written such that the bookmarks are not replaced; values are inserted before the bookmark

~~~~~~~~~~~~~ MDB

The database has one table, t_PEOPLE, which includes the fields Lastname and Firstname

There is one query, qryWriteToWord, which chooses the records to write

There is one module, mod_WriteToWord

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Option Compare Database
Option Explicit

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' Crystal strive4peace  100111
'
Sub RunCreate_WordDoc()
   Dim mQueryName As String _
      , mSavePath As String _
      , mTemplatename As String _
      , mNumDocuments As Integer _
      , mMsg As String _
      , mStartTime As Date
   
   mStartTime = Now()

   mQueryName = "qryWriteToWord"
   
   'put documents in a directory
   ' called DOCS below db directory
   
   mSavePath = CurrentProject.Path & "\DOCS"
   
   mTemplatename = CurrentProject.Path _
      & "\WriteToWord.Dot"
      
   mNumDocuments = Create_WordDoc( _
      mQueryName, _
      mSavePath, _
      mTemplatename)

   If mNumDocuments = 0 Then
      mMsg = "No Documents were made"
   Else
      mMsg = "Done making " & mNumDocuments & " documents"
   End If
   
    MsgBox mMsg _
      , , "Time to complete: " & DateDiff( _
         "s", mStartTime, Now()) & " seconds"

End Sub

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function Create_WordDoc( _
   pQueryName As String _
   , pSavePath As String _
   , pTemplatename As String _
   ) As Integer
      
   'crystal
   'strive4peace
   
   'NEEDS REFERENCE
   'Microsoft Word #.# Object Library
   'for early binding
   
   On Error GoTo Proc_Err
   
   'LEN is length
   'TRIM leading and trailing space
   'NZ is null to zero
   
   If Len(Trim(Nz(pSavePath))) = 0 Then
      pSavePath = CurrentProject.Path & "\"
   Else
      If Right(pSavePath, 1) <> "\" Then
         pSavePath = pSavePath & "\"
      End If
   End If
   
   On Error Resume Next
   'make path if it doesn't exist
   ' -- will only work for last level directory
   
   If Len(Trim(Dir(pSavePath, vbDirectory))) = 0 Then
      MkDir pSavePath
   End If
   On Error GoTo Proc_Err
   
   If Len(Trim(Dir(pSavePath, vbDirectory))) = 0 Then
      MsgBox pSavePath & " is not valid", , "Cannot continue"
      GoTo Proc_Exit
   End If
         
   'Returns
   'True if documents were written
   'false if no data was found
   
   Create_WordDoc = 0
   
   'for late binding, wrdApp will be --> As Object
   Dim rs As Recordset _
      , wrdApp As Word.Application
      
   Dim mTemplatename As String _
      , mfilename As String _
      , booCloseWord As Boolean _
      , mNumDocuments As Integer
      
   Set rs = CurrentDb.OpenRecordset( _
      pQueryName, dbOpenSnapshot)
      
   'Make sure there are records to write
   
   If rs.EOF Then
      MsgBox pQueryName _
         & vbCrLf _
         & "Can't write Documents --> " _
         & pSavePath, , "no Data"
      rs.Close
      Set rs = Nothing
      Exit Function
   End If
     
   rs.MoveFirst
   
   'if Word is already open, use that instance
   ' ignore errors because if Word is NOT open
   ' we will get one
   On Error Resume Next
   'make assumption that Word is Open
   booCloseWord = False
   Set wrdApp = GetObject(, "Word.Application")
   On Error GoTo Proc_Err
     
    'What did we find?...
   If TypeName(wrdApp) = "Nothing" Then
      'Word was not open -- create a new instance
      Set wrdApp = CreateObject("Word.Application")
      booCloseWord = True
   End If
       
   wrdApp.Visible = False
    
   'see if there is a template to use
   '  for creating new documents
   If Len(pTemplatename) > 0 Then
      'if directory not specified
      '  assume template is in database directory
      If InStr(pTemplatename, "\") = 0 Then
       mTemplatename = CurrentProject.Path _
         & "\" & pTemplatename
      Else
       mTemplatename = pTemplatename
      End If
   End If
   
   mNumDocuments = 0
   
   'Make sure template exists
   If Len(mTemplatename) > 0 Then
      'make sure template exists
      If Len(Trim(Dir(mTemplatename))) = 0 Then
      
         MsgBox mTemplatename _
            & " is not a valid template name" _
            , , "Cannot continue"
            
         GoTo Proc_Exit
      End If
   Else
   
      MsgBox "You must specify a template for the documents" _
         , , "Cannot continue"
         
      GoTo Proc_Exit
   End If
   
   Do While Not rs.EOF
      SysCmd acSysCmdSetStatus _
         , "Writing Word documents: " & mNumDocuments
      
      'create a name for the file based on field values
      mfilename = pSavePath & Nz(rs!LastName) _
         & "_" & Nz(rs!FirstName) & ".doc"
      
      'if that file already exists
      '  delete it
      If Dir(mfilename) <> "" Then
         Kill mfilename
      End If
      
      'create new Word doc based on template
      wrdApp.Documents.Add mTemplatename
      
      
      With wrdApp.ActiveDocument
        
        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Search/Replace
         '--------- use in case you have >1 occurence to find
'        'look for all occurences of a string
'        'replace with field values
'
'         With .Content.Find
'           .Execute FindText:="Firstname", ReplaceWith:=Nz(rs!FirstName)
'           .Execute FindText:="Lastname", ReplaceWith:=Nz(rs!LastName)
'         End With
         
        '~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Replace Bookmarks
         '--------- use to replace bookmarks
         'make sure your code is in order bookmarks are found
         
         'wdGoToBookmark --> -1
         
         With .Goto(What:=-1, Name:="Firstname")
            .InsertBefore rs!FirstName
         End With
      
         With .Goto(What:=-1, Name:="LastName")
            .InsertBefore rs!LastName
         End With
         
         'save file
         .SaveAs mfilename
         
         'Close File without saving changes
         '(since we just saved it)
         .Close , False
         
       End With
      
      'increment number of documents written
      mNumDocuments = mNumDocuments + 1
      
      'move to next record
      rs.MoveNext
   Loop
         
   Create_WordDoc = mNumDocuments
   
Proc_Exit:
   On Error Resume Next
   If Not rs Is Nothing Then
      rs.Close
      Set rs = Nothing
   End If
   
   If Not wrdApp Is Nothing Then
      If booCloseWord = True Then
         wrdApp.Quit
      End If
      Set wrdApp = Nothing
   End If
   
   SysCmd acSysCmdClearStatus
   
   Exit Function
    
Proc_Err:
   MsgBox Err.Description _
      , , "ERROR " & Err.Number & "   Create_WordDoc"
   
   'comment next line after debugged
   'press F8 to step thru code
   Stop: Resume
   
   Resume Proc_Exit
   
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
