The second part of the article on merging Access data with Word documents.
Access Archon #130
The remaining part of the cmdWordDocs Click event procedure is listed below, with the code for the Doc Props, Mail Merge and TypeText methods for merging Access data to Word documents.
DocProps:
With rst
Do While Not .EOF
‘Check for required address information
strTest = Nz(![Address])
Debug.Print “Street address: ” & strTest
If strTest = “” Then
MsgBox “Can’t send letter — no street address!”
GoTo NextRecordDP
End If
strName = Nz(![FirstNameFirst])
strJobTitle = Nz(![JobTitle])
If strJobTitle <> “” Then
strNameAndJobTitle = strName & vbCrLf & strJobTitle
End If
‘Open a new document based on the selected template
pappWord.Documents.Add strWordTemplate
‘Write information to Word custom document properties
Set prps = pappWord.ActiveDocument.CustomDocumentProperties
prps.Item(“Name”).Value = strNameAndJobTitle
On Error Resume Next
prps.Item(“Salutation”).Value = Nz(![Salutation])
prps.Item(“CompanyName”).Value = Nz(![CompanyName])
prps.Item(“Address”).Value = Nz(![Address])
prps.Item(“TodayDate”).Value = strLongDate
On Error GoTo ErrorHandler
‘Check for existence of previously saved letter in documents folder,
‘and append an incremented number to save name if found
strDocType = pappWord.ActiveDocument.BuiltInDocumentProperties(2)
strSaveName = strDocType & ” to ” & strName
strSaveName = strSaveName & ” on ” & strShortDate & “.doc”
i = 2
intSaveNameFail = True
Do While intSaveNameFail
strSaveNamePath = strDocsPath & strSaveName
Debug.Print “Proposed save name and path: ” _
& vbCrLf & strSaveNamePath
strTestFile = Nz(Dir(strSaveNamePath))
Debug.Print “Test file: ” & strTestFile
If strTestFile = strSaveName Then
Debug.Print “Save name already used: ” & strSaveName
‘Create new save name with incremented number
intSaveNameFail = True
strSaveName = strDocType & ” ” & CStr(i) & ” to ” & strName
strSaveName = strSaveName & ” on ” & strShortDate & “.doc”
strSaveNamePath = strDocsPath & strSaveName
Debug.Print “New save name and path: ” _
& vbCrLf & strSaveNamePath
i = i + 1
Else
Debug.Print “Save name not used: ” & strSaveName
intSaveNameFail = False
End If
Loop
‘Update fields in Word document and save it
With pappWord
.Selection.WholeStory
.Selection.Fields.Update
.Selection.HomeKey Unit:=wdStory
.ActiveDocument.SaveAs strSaveName
End With
.MoveNext
NextRecordDP:
Loop
End With
‘Activate Word
With pappWord
.ActiveWindow.WindowState = 0
.Visible = True
.Activate
End With
GoTo ErrorHandlerExit
MailMerge:
‘Write data from filtered query to a table for mail merge
‘Address checking is done in the append query
strTable = “tblMergeList”
strSQL = “DELETE tblMergeList.* FROM tblMergeList;”
DoCmd.SetWarnings False
DoCmd.RunSQL strSQL
DoCmd.OpenQuery “qappFilteredContacts”
‘Export merge table to a text file
strDBPath = Application.CurrentProject.Path & “”
strTextFile = strDBPath & “Merge Data.txt”
Debug.Print “Text file for merge: ” & strTextFile
DoCmd.TransferText transfertype:=acExportDelim, TableName:=strTable, _
FileName:=strTextFile, HasFieldNames:=True
‘Open a new merge document based on the selected template
pappWord.Documents.Add strWordTemplate
strDocName = pappWord.ActiveDocument.Name
Debug.Print “Initial doc name: ” & strDocName
‘Check for existence of previously saved letter in documents folder,
‘and append an incremented number to save name if found
strDocType = pappWord.ActiveDocument.BuiltInDocumentProperties(2)
strSaveName = strDocType & ” on ” & strShortDate & “.doc”
i = 2
intSaveNameFail = True
Do While intSaveNameFail
strSaveNamePath = strDocsPath & strSaveName
Debug.Print “Proposed save name and path: ” _
& vbCrLf & strSaveNamePath
strTestFile = Nz(Dir(strSaveNamePath))
‘Debug.Print “Test file: ” & strTestFile
If strTestFile = strSaveName Then
‘Debug.Print “Save name already used: ” & strSaveName
‘Create new save name with incremented number
intSaveNameFail = True
strSaveName = strDocType & ” ” & CStr(i) & _
” on ” & strShortDate & “.doc”
strSaveNamePath = strDocsPath & strSaveName
‘Debug.Print “New save name and path: ” _
& vbCrLf & strSaveNamePath
i = i + 1
Else
‘Debug.Print “Save name not used: ” & strSaveName
intSaveNameFail = False
End If
Loop
‘Set the merge data source to the text file just created,
‘and do the merge
With pappWord
.ActiveDocument.MailMerge.OpenDataSource Name:=strTextFile, _
Format:=wdOpenFormatText
.ActiveDocument.MailMerge.Destination = wdSendToNewDocument
.ActiveDocument.MailMerge.Execute
.ActiveDocument.SaveAs strSaveNamePath
.Documents(strDocName).Close SaveChanges:=wdDoNotSaveChanges
.Visible = True
End With
GoTo ErrorHandlerExit
TypeText:
‘Open a new letter based on the selected template
pappWord.Documents.Add strWordTemplate
Do While Not rst.EOF
‘Check for required address information
strTest = Nz(rst![Address])
Debug.Print “Street address: ” & strTest
If strTest = “” Then
MsgBox “Can’t send letter — no street address!”
GoTo NextRecordTT
End If
strName = Nz(rst![FirstNameFirst])
strJobTitle = Nz(rst![JobTitle])
If strJobTitle <> “” Then
strNameAndJobTitle = strName & vbCrLf & strJobTitle
End If
‘Insert data into a label
With pappWord.Selection
.TypeText Text:=strName
.TypeParagraph
.TypeText Text:=strJobTitle
.TypeParagraph
.TypeText Text:=Nz(rst![CompanyName])
.TypeParagraph
.TypeText Text:=Nz(rst![Address])
.TypeParagraph
.MoveRight Unit:=wdCell
End With
NextRecordTT:
rst.MoveNext
Loop
‘Check for existence of previously saved document in documents folder,
‘and append an incremented number to save name if found
strDocType = pappWord.ActiveDocument.BuiltInDocumentProperties(2)
strSaveName = strDocType & ” on ” & strShortDate & “.doc”
i = 2
intSaveNameFail = True
Do While intSaveNameFail
strSaveNamePath = strDocsPath & strSaveName
Debug.Print “Proposed save name and path: ” _
& vbCrLf & strSaveNamePath
strTestFile = Nz(Dir(strSaveNamePath))
Debug.Print “Test file: ” & strTestFile
If strTestFile = strSaveName Then
Debug.Print “Save name already used: ” & strSaveName
‘Create new save name with incremented number
intSaveNameFail = True
strSaveName = strDocType & ” ” & CStr(i) & _
” on ” & strShortDate & “.doc”
strSaveNamePath = strDocsPath & strSaveName
Debug.Print “New save name and path: ” _
& vbCrLf & strSaveNamePath
i = i + 1
Else
Debug.Print “Save name not used: ” & strSaveName
intSaveNameFail = False
End If
Loop
With pappWord
.Selection.HomeKey Unit:=wdStory
.ActiveDocument.SaveAs strSaveNamePath
.Visible = True
.ActiveWindow.WindowState = 0
.Activate
End With
ErrorHandlerExit:
Set pappWord = Nothing
Exit Sub
ErrorHandler:
‘Word is not running; open Word with CreateObject
If Err.Number = 429 Then
Set pappWord = CreateObject(“Word.Application”)
Resume Next
Else
MsgBox “Error No: ” & Err.Number & “; Description: “
Resume ErrorHandlerExit
End If
End Sub
References
The code in the sample database needs the following references (in addition to the default references):
Microsoft DAO 3.6 Object Library
Microsoft Scripting Runtime
Microsoft Word 11.0 Object Library
If you import code or objects into a database of your own, you may need to set one or more of these references. The version number may differ, depending on your Office version; check the version you have. References are set in the References dialog, opened from the VBA window. For more information on working with references, see Access Archon #107, Working with References.
Supporting Files
The zip file containing this article, in Word format, plus the supporting file(s), may be downloaded from the Access Archon page of my Web site. It is accarch130zip, which is the last entry in the table of Access Archon columns for Access Watch.
|
Document Name |
Document Type |
Place in |
|
Filter and Merge.mdb |
Access 2000 database (can also be used in higher versions of Access) |
Wherever you want |
|
Avery 5160 Labels.dot |
Word templates |
Templates folder (usually C:Program FilesMicrosoft OfficeTemplates |
