Creating Word 97 document merge datasources

by Chris Rowlett
21st Century Work Place, Inc.
Dallas, TX   75240
214.435.4703
http://www.tfwpa.com/

This is a procedure that we wrote to provide a way for our client to easily merge data contained in their Access 97 database with documents in Word 97.  the main concern of the client was that they needed to make modifications to the word processing documents and needed flexibility that using Access reports would not provide.   Basically, this procedure uses an Access form with which the client selects the database record that they want to print.  Then the user presses the button on the form named btnPrintLetter.  The click event of this button is described below in Private Sub btnPrintLetter_Click(). 

The procedure executes as follows:

>Gets the main application's data path
>Creates the new engagement letter's document name as "EL_JOBID.doc"
>Sets the static template letter name called EngagementLetter.doc
>Creates the Datasource file name as "DS_JOBID.doc"
>Checks to see if this new letter name already exists in the \documents\ folder
>Asks the user if they want to edit an existing letter or delete it
>Either opens the existing letter or deletes the existing letter
>If the users deletes and creates a new letter the procedure copies the template document from the \templates\ sub folder and renames it and stores it in the \documents\ sub folder
>The procedure then selects the data for the datasource and creates the datasource file.
>Finally, Word97 is opened, set to the appropriate document and the mail merge data source is reset to the new datasource to be used.
>The user now has flexibility to move and change and add text to the document.

Private Sub btnPrintLetter_Click()
Dim strErrorMsg As String
On Error GoTo Err_btnPrintLetter_Click


'Validate the Data
'Save the data
btnSave_Click
If bSaved = True Then
'Check to be sure this has a JOB_ID
If IsNull(Me.JobID) = False Then

DoCmd.Hourglass True

Dim dbDefault As Database
Dim rstDefault As Recordset
Dim strFileName As String      'The new letter file name
Dim strTest As String                'The file name returned by the directory lookup
Dim intAnswer As Integer       ' The Answer to a question
Dim intSuccess As Boolean      'Indicator whether an operation was successful or not


'Get the file path information
'Get the data path to the default table
Set dbDefault = CurrentDb
Set rstDefault = dbDefault.OpenRecordset("tblAppDefaults", dbOpenDynaset)
rstDefault.MoveFirst
Me.DataPath = rstDefault![DataPath]
rstDefault.Close


'Name the EngagementLetter
Me.EngagementLetterName = "EL_" & Me.JobID & ".doc"

'Name the Template
Me.LetterTemplateName = "EngagementLetter.doc"

'Name the Data Source
Me.DataSourceName = "DS_" & Me.JobID & ".doc"

'Check to see if this letter exists. If it does take the appropriate action
If fncCheckExistingDocs(Me.DataPath, Me.EngagementLetterName) = True Then
intAnswer = MsgBox("This letter already exists " & Me.EngagementLetterName & Chr(13) _
& Chr(13) & "Do you want to Edit/View it or Delete it?" & Chr(13) _
& Chr(13) & "Selecting Yes, means you want to Edit or View the letter." _
& Chr(13) & Chr(13) & "Selecting NO, means you want to Delete the letter and prepare a new one.", vbYesNoCancel, "Existing Letter")

Select Case intAnswer

Case Is = vbYes
'Yes, I do want to edit this letter
'MsgBox "Edit the letter"
'Open the existing letter file
intSuccess = fncMergeLetter(Me.DataPath, Me.EngagementLetterName, Me.DataSourceName)
GoSub Exit_btnPrintLetter_Click

Case Is = vbNo
'No, I do not want to edit the letter, I want to delete it and generate a new one.
'MsgBox "Delete the letter"
'Delete the letter file and the datasource(if exists), copy over a new template and open it
If fncDeleteLetter(Me.DataPath, Me.EngagementLetterName, Me.DataSourceName) = True Then
'Continue with this procedure below
Else
MsgBox "Could not delete the existing letter." & Chr(13) & "Operation could not be completed."
GoSub Exit_btnPrintLetter_Click
End If

Case Else
'Forget I ever asked! Cancel, Bail out, Eject!
'Hey, I'm not FAT, I'm just big boned! Carteman
'MsgBox "Cancel"
GoSub Exit_btnPrintLetter_Click

End Select
End If
'If the letter does not exist or if it was deleted above, then create a new one.
If fncCopyLetterTemplate(Me.DataPath, Me.LetterTemplateName, Me.EngagementLetterName) = True Then
Dim rstDataSource As Recordset
Dim strSQL As String
' Open dynaset-type Recordset object.
' Had to write all this Text-export code because I could not get the builtin text export to work the way I needed
strSQL = "SELECT * FROM qryMerge_EngagementLetter WHERE ( [ASRID] = " & Me.ASRID & " );"
Set rstDataSource = dbDefault.OpenRecordset(strSQL, dbOpenDynaset)
rstDataSource.MoveFirst
If fncCreateDSFile(Me.DataPath, Me.DataSourceName, rstDataSource) = True Then
'Crank up Word and do the nasty merge
intSuccess = fncMergeLetter(Me.DataPath, Me.EngagementLetterName, Me.DataSourceName)
End If
'Send the datapath and EngagementLettername to the merge routine
Else
MsgBox "Could not Find or could not Copy the template file " & Me.LetterTemplateName & " . Check to see that the directory paths are correctly set and that the template documents are in the template subdirectory."
End If
Else
MsgBox "Please assign a Job ID first"
End If

Else
MsgBox "Could not save record, therefore letter was not printed"
End If



Exit_btnPrintLetter_Click:
DoCmd.Hourglass False
Exit Sub


Err_btnPrintLetter_Click:
DoCmd.Hourglass False
If Err.Number <> 0 Then
strErrorMsg = "Error # " & str(Err.Number) & " was generated by " _
& Err.Source & " " & Me.Name & Chr(13) & Err.Description
MsgBox strErrorMsg, , "Error"

Resume Exit_btnPrintLetter_Click
End If
End Sub

Function fncMergeLetter(strDataPath As String, strLetterFileName As String, strDSFileName As String)
Dim strErrorMsg As String
On Error GoTo Err_fncMergeLetter


'This function creates a Word97 object, Document and MailMerge object
'Then the function adds the static folder called "\documents\" to the path
'Then opens the strLetterFileName like "myletter.doc" in the strDataPath
'like "c:\word\documents\myletter.doc"

'Then the function changes the document's datasource to the datasource designated by strDSFileName
'then it sets the property for the mail merge object to view the data, rather than the merge codes.


'strDataPath is the path to the datafile directory like c:\words
'strLetterFileName is the name of the letter file to use like myletter.doc
'strDSFileName is the name of the datasource to use like mydata.doc

fncMergeLetter = False


Dim objWord As New Word.Application
Dim objWordDoc As Word.Document
Dim objMailMerge As Word.MailMerge

'Use the Open method to open the file.
objWord.Documents.Open FileName:=strDataPath & "\documents\" & strLetterFileName
'Set word to be visible
objWord.Visible = True
Set objMailMerge = objWord.ActiveDocument.MailMerge
'Change the datasource to the correct jobID datasource
objMailMerge.OpenDataSource strDataPath & "\datasources\" & strDSFileName
objMailMerge.ViewMailMergeFieldCodes = False


fncMergeLetter = True

Exit_fncMergeLetter:
Exit Function


Err_fncMergeLetter:
If Err.Number <> 0 Then
strErrorMsg = "Error # " & str(Err.Number) & " was generated by " _
& Err.Source & " fncMergeLetter " & Chr(13) & Err.Description
MsgBox strErrorMsg, , "Error"

Resume Exit_fncMergeLetter
End If

End Function

Function fncCheckForDSDirectory(strDataPath As String)
Dim strErrorMsg As String
On Error GoTo Err_fncCheckForDSDirectory

Dim strTest As String

'This function checks to see if a Data Source Directory exists and creates one if not

fncCheckForDSDirectory = False

'check to see if the datasource directory exists
strTest = Dir(strDataPath & "\datasources", vbDirectory)
'If Dir returns a non-zero length string then it found an existing file
If Len(strTest) > 0 Then
'Continue
fncCheckForDSDirectory = True
Else
'Create the datasources directory if it does not exist
strErrorMsg = "Creating the datasources subdirecory " & strDataPath & "\datasources " & Chr(13)
MkDir strDataPath & "\datasources"
fncCheckForDSDirectory = True
End If

Exit_fncCheckForDSDirectory:
Exit Function


Err_fncCheckForDSDirectory:
If Err.Number <> 0 Then
strErrorMsg = "Error # " & str(Err.Number) & " was generated by " _
& Err.Source & " fncCheckForDSDirectory " & Chr(13) & Err.Description
MsgBox strErrorMsg, , "Error"

Resume Exit_fncCheckForDSDirectory
End If


End Function

Function fncCreateDSFile(strDataPath As String, strFileName As String, rst As Recordset)
Dim strErrorMsg As String
On Error GoTo Err_fncCreateDSFile

Dim fld As Field
Dim bFirstLoop As Boolean 'indicates if this is the first time thru the loop
Dim intSuccessful As Boolean 'indicates whether an action was successful

fncCreateDSFile = False


'This function creates the Datasource file to be used in the mail merge operation
'First it checks to see if the Datasource directory exists, then begins creating the file
'Then the function loops thru the recordset to print the field names to the file, then
'it loops thru the recordset data values and prints those values to the merge file

'strDataPath As String this is the path to the applications main folder like c:\words
'strFileName As String this is the name of the datasource file to create
'rst As Recordset this is the recordset providing the values to use in the merge file

If fncCheckForDSDirectory(strDataPath) = True Then
Open strDataPath & "\datasources\" & strFileName For Output As #1
bFirstLoop = True
For Each fld In rst.Fields
If Not bFirstLoop Then
'print a tab
Print #1, Chr(9);
End If

' Print field name.
Print #1, Chr(34) & fld.Name & Chr(34);
bFirstLoop = False
Next fld
Print #1, Chr(13);

bFirstLoop = True
' Print field Value.
For Each fld In rst.Fields
If Not bFirstLoop Then
'print a tab
Print #1, Chr(9);
End If

'Print the values to the file in the appropriate format.
'Scan for null values and change them to spaces or blanks
Select Case fld.Type

Case Is = dbText
If IsNull(fld.Value) Then
Print #1, Chr(34) & "" & Chr(34);
Else
Print #1, Chr(34) & fld.Value & Chr(34);
End If

Case Is = dbTime
If IsNull(fld.Value) Then
Print #1, Chr(34) & "" & Chr(34);
Else
Print #1, Chr(34) & Format(fld.Value, "hh:mm am/pm") & Chr(34);
End If

Case Is = dbDate
If IsNull(fld.Value) Then
Print #1, Chr(34) & "" & Chr(34);
Else
Print #1, Chr(34) & Format(fld.Value, "mm/dd/yy") & Chr(34);
End If

Case Is = dbMemo
If IsNull(fld.Value) Then
Print #1, Chr(34) & "" & Chr(34);
Else
Print #1, Chr(34) & fld.Value & Chr(34);
End If

Case Is = dbCurrency
If IsNull(fld.Value) Then
Print #1, Chr(34) & "" & Chr(34);
Else
Print #1, fld.Value;
End If


Case Is = dbBoolean
If fld.Value = True Then
Print #1, Chr(34) & "yes" & Chr(34);
Else
Print #1, Chr(34) & "no" & Chr(34);
End If


Case Is = dbChar
If IsNull(fld.Value) Then
Print #1, Chr(34) & "" & Chr(34);
Else
Print #1, Chr(34) & fld.Value & Chr(34);
End If
'ignore the following data types, none are in this data file
'Case Is = dbByte
'Case Is = dbNumeric
'Case Is = dbBigInt
'Case Is = dbBinary
'Case Is = dbDecimal
'Case Is = dbDouble
'Case Is = dbFloat
'Case Is = dbGUID
'Case Is = dbInteger
'Case Is = dbLong
'Case Is = dbLongBinary
'Case Is = dbSingle
'Case Is = dbTimeStamp
'Case Is = varBinary

Case Else
If IsNull(fld.Value) Then
Print #1, Chr(34) & "" & Chr(34);
Else
Print #1, fld.Value;
End If

End Select

bFirstLoop = False
Next fld
'Print #1, Chr(13)

fncCreateDSFile = True
Close #1
Else
MsgBox "Could not create the Datasource subdirectory", vbCritical, "Critical Error"
End If


Exit_fncCreateDSFile:
Exit Function


Err_fncCreateDSFile:
Close #1
If Err.Number <> 0 Then
strErrorMsg = "Error # " & str(Err.Number) & " was generated by " _
& Err.Source & " fncCreateDSFile " & Chr(13) & Err.Description
MsgBox strErrorMsg, , "Error"

Resume Exit_fncCreateDSFile
End If

End Function

Function fncCheckExistingTemplates(strPathName As String, strFileName As String)
Dim strErrorMsg As String
On Error GoTo Err_fncCheckExistingTemplates

'This function checks to see if the template directory exists
'it also checks to see if the template document exists
'the template document is a document previously created in word97 specifically
'for the purpose of using as a merge template.
'the templates are stored in the \templates\ sub folder of the applications main folder

Dim strTest As String

fncCheckExistingTemplates = False

'Check to see if this Template Directory Path exists already
strTest = Dir(strPathName & "\templates", vbDirectory)
'If Dir returns a non-zero length string then it found an existing file
If Len(strTest) > 0 Then
'Continue
Else
'Create the Templates directory if it does not exist
strErrorMsg = "Creating the templates subdirecory " & strPathName & "\templates " & Chr(13)
MkDir strPathName & "\templates"
End If


'Check to see if this template letter exists
strTest = Dir(strPathName & "\templates\" & strFileName, vbNormal)
'If Dir returns a non-zero length string then it found an existing file
If Len(strTest) > 0 Then
fncCheckExistingTemplates = True
End If



Exit_fncCheckExistingTemplates:
Exit Function


Err_fncCheckExistingTemplates:
If Err.Number <> 0 Then
strErrorMsg = strErrorMsg & "- Error # " & str(Err.Number) & " was generated by " _
& Err.Source & " fncCheckExistingTemplates " & Chr(13) & Err.Description
MsgBox strErrorMsg, , "Error"

Resume Exit_fncCheckExistingTemplates
End If



End Function

Function fncCheckExistingDocs(strPathName As String, strFileName As String)
Dim strErrorMsg As String
On Error GoTo Err_fncCheckExistingDocs

'This function checks to see if a merged document already exists
'with this document name

Dim strTest As String
strTest = ""
fncCheckExistingDocs = False

'Check to see if this Document Directory Path exists already
strTest = Dir(strPathName & "\documents", vbDirectory)
'If Dir returns a non-zero length string then it found an existing file
If Len(strTest) > 0 Then
'Continue
Else
'Create the Documents directory if it does not exist
strErrorMsg = "Creating the documents subdirecory " & strPathName & "\documents " & Chr(13)
MkDir strPathName & "\documents"
End If


'Check to see if this letter exists already
strTest = Dir(strPathName & "\documents\" & strFileName, vbNormal)
'If Dir returns a non-zero length string then it found an existing file
If Len(strTest) > 0 Then
fncCheckExistingDocs = True
End If



Exit_fncCheckExistingDocs:
Exit Function


Err_fncCheckExistingDocs:
If Err.Number <> 0 Then
strErrorMsg = strErrorMsg & "- Error # " & str(Err.Number) & " was generated by " _
& Err.Source & " fncCheckExistingDocs " & Chr(13) & Err.Description
MsgBox strErrorMsg, , "Error"

Resume Exit_fncCheckExistingDocs
End If



End Function

Function fncCopyLetterTemplate(strPathName As String, strTemplateName As String, strNewDocName As String)
Dim strErrorMsg As String
On Error GoTo Err_fncCopyLetterTemplate

'This function makes a copy of the document template and stores it in the documents directory


Dim intSuccess As Boolean
Dim strCopyFrom As String
Dim strCopyTo As String

fncCopyLetterTemplate = False

'Check to see if the Template Exists
intSuccess = fncCheckExistingTemplates(strPathName, strTemplateName)
If intSuccess = True Then
'rename and copy template to documents directory
strCopyFrom = strPathName & "\templates\" & strTemplateName
strCopyTo = strPathName & "\documents\" & strNewDocName
'FileCopy SourceFile, DestinationFile ' Copy source to target.
FileCopy strCopyFrom, strCopyTo
fncCopyLetterTemplate = True
End If


Exit_fncCopyLetterTemplate:
Exit Function


Err_fncCopyLetterTemplate:
If Err.Number <> 0 Then
strErrorMsg = "Error # " & str(Err.Number) & " was generated by " _
& Err.Source & " fncCopyLetterTemplate " & Chr(13) & Err.Description
MsgBox strErrorMsg, , "Error"

Resume Exit_fncCopyLetterTemplate
End If

End Function

Function fncDeleteLetter(strPathName As String, strDocName As String, strDataSource As String)
Dim strErrorMsg As String
On Error GoTo Err_fncDeleteLetter

Dim intSuccess As Boolean
Dim strDelete As String
Dim strTest As String

'This function deletes a letter from the documents directory and
'it also deletes the corresponding datasource if it exists


fncDeleteLetter = False
'Check to see if this letter exists
strTest = Dir(strPathName & "\documents\" & strDocName, vbNormal)
'If Dir returns a non-zero length string then it found an existing file
If Len(strTest) > 0 Then
strDelete = strPathName & "\documents\" & strDocName
'Kill "TestFile" ' Delete file.
Kill strDelete
fncDeleteLetter = True
End If

'Check to see if this letter has an existing datasource
strTest = Dir(strPathName & "\datasource\" & strDataSource, vbNormal)
'If Dir returns a non-zero length string then it found an existing file
If Len(strTest) > 0 Then
strDelete = strPathName & "\datasource\" & strDataSource
Kill strDelete
End If


Exit_fncDeleteLetter:
Exit Function


Err_fncDeleteLetter:
If Err.Number <> 0 Then
strErrorMsg = "Error # " & str(Err.Number) & " was generated by " _
& Err.Source & " fncDeleteLetter " & Chr(13) & Err.Description
MsgBox strErrorMsg, , "Error"

Resume Exit_fncDeleteLetter
End If

End Function