Documents

You can use mail merge to create a merge document, where each page displays data from one contact record. I prefer to use the document properties or bookmarks method, in order to have a separate document for each contact, but if you have many hundreds (or thousands) of documents to generate, this is not practical. The Contact Letters (Mail Merge) selection in the Select Document combo box creates a mail merge document with a letter on each page; Figure 6.25 shows one page of this merge document.

FIGURE 6.24

The Contact List filled with merged data from Access.

FIGURE 6.24

The Contact List filled with merged data from Access.

^ :/,■-■:; ¡pvsgs If a merge document with the Merge Data.txt data source is open, if you try to create another merge document bound to the same data source, you will get an error message saying that Merge Data.txt already exists, and you won't be able to continue. To prevent this from happening, the mail merge code closes the original merge document after merging the data to a new document.

The MailMergeTextFile procedure is listed as follows. This procedure first fills an Access table with data from the ItemsSelected collection of the ListBox, and then exports the data from that table to a text file, Merge Data.txt, which is used as the data source for the mail merge document. The merge is executed to a new document (so the document can be opened later, without needing the data source) and saved to a name picked up from the templates Title field and the date, formatted with dashes to avoid file name problems:

FIGURE 6.25

The third page of a mail merge form letters document.

FIGURE 6.25

The third page of a mail merge form letters document.

Private Sub MailMergeTextFile(strWordTemplate As String, strExtension As String)

On Error GoTo ErrorHandler

Dim rst As DAO.Recordset Dim dbs As DAO.Database Dim strDBPath As String Dim strTextFile As String Dim strDocName As String Dim strSalutation As String Dim strZipCode As String Dim strSQL As String Dim strTable As String strLongDate = Format(Date, "mmmm d, yyyY") strShortDate = Format(Date, "m-d-yyYY") strDocsPath = GetContactsDocsPath() Debug.Print "Docs path: " & strDocsPath strTemplatePath = GetContactsTemplatesPath()

Check that at least two contacts have been selected, because there is no point of doing a mail merge to only one contact:

Set 1st = Me![lstSelectContacts]

If lst.ItemsSelected.Count < 0 Then

MsgBox "Please select at least one contact" lst.SetFocus GoTo ErrorHandlerExit End If

Clear the merge data table of old data:

DoCmd.SetWarnings False strTable = "tblMergeData"

strSQL = "DELETE * FROM " & strTable

DoCmd.RunSQL strSQL

Create a recordset based on the table of merge data:

Set dbs = CurrentDb

Set rst = dbs.OpenRecordset(Name:=strTable)

intColumns = lst.ColumnCount intRows = lst.ItemsSelected.Count

For Each varItem In lst.ItemsSelected

Check for required address information:

strTest = Nz(lst.Column(5, varItem)) Debug.Print "Street address: " & strTest If strTest = "" Then

Debug.Print "Skipping this record -- no address!" GoTo NextContact End If strTest = Nz(lst.Column(1, varItem)) Debug.Print "Contact name: " & strTest If strTest = "" Then Debug.Print _

"Skipping this record -- no contact name!" GoTo NextContact End If strContactName = _

Nz(lst.Column(1, varltem)) strCompanyName = _

Nz(lst.Column(7, varltem)) strNameTitleCompany = _

Nz(lst.Column(2, varltem)) strWholeAddress = Nz(lst.Column(5, varltem)) strSalutation = Nz(lst.Column(10, varltem)) strJobTitle = Nz(lst.Column(8, varltem)) strZipCode = Nz(lst.Column(6, varltem))

Add records to the table from the selected items in the ListBox:

With rst .AddNew

![NameTitleCompany] = strNameTitleCompany ![WholeAddress] = strWholeAddress ![Salutation] = strSalutation ![TodayDate] = strLongDate ![CompanyName] = strCompanyName ![JobTitle] = strJobTitle ![ZipCode] = strZipCode ![ContactName] = strContactName .Update End With

NextContact:

Next varltem rst.Close

Export the merge table data to a text file, to be used as the mail merge documents data source:

strTextFile = strTemplatePath & "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:

Set appWord = GetObject(Class:="Word.Application") appWord.Documents.Add strWordTemplate appWord.Visible = True strDocName = appWord.ActiveDocument.Name Debug.Print "Initial doc name: " & strDocName

Check for a previously saved document in the documents folder, and append an incremented number to the save name if one is found:

strDocType = _

appWord.ActiveDocument.

BuiltlnDocumentProperties(wdPropertyTitle) strSaveName = strDocType & " on " _

& strShortDate & strExtension 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 a new save name with the incremented number:

intSaveNameFail = True strSaveName = strDocType & " " & CStr(i) & " on " _

& strShortDate & strExtension strSaveNamePath = strDocsPath & strSaveName Debug.Print "New save name and path: " _

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 appWord

.ActiveDocument.MailMerge.OpenDataSource _ Name:=strTextFile, _ Format:=wdOpenFormatText .ActiveDocument.MailMerge.Destination = _

wdSendToNewDocument .ActiveDocument.MailMerge.Execute

Save the newly created merge document:

.ActiveDocument.SaveAs strSaveNamePath

Close the master merge document:

.Documents(strDocName).Close _

SaveChanges:=wdDoNotSaveChanges End With

ErrorHandlerExit: Exit Sub

ErrorHandler:

Word is not running; open Word with CreateObject:

Set appWord = CreateObject(Class:="Word.Application") Resume Next Else

& "; Description: " & Err.Description Resume ErrorHandlerExit End If

End Sub

Was this article helpful?

0 0

Post a comment