Word Bookmarks

If you select the Contact Letter with Envelope (Bookmarks) template from the Select Document combo box on frmMergeToWord, you will get a set of individual letters, one to each selected contact, with bookmarks filled with Access data. One of these letters is shown in Figure 6.20 (I made bookmarks visible so you can see their locations; note the gray I-bars).

The MergeBookmarks procedure (listed next) is basically similar to the MergeDocProps code listed in an earlier section; the difference is that instead of working with the CustomDocumentProperties collection, it works with the Bookmarks collection, writing information from either variables or the listbox to named bookmarks in the newly created Word document:

Private Sub MergeBookmarks(strWordTemplate As String, _ strExtension As String)

On Error GoTo ErrorHandler strLongDate = Format(Date, "mmmm d, yyyy") strShortDate = Format(Date, "m-d-yyyy") strDocsPath = GetContactsDocsPath() Debug.Print "Docs path: " & strDocsPath

FIGURE 6.20

A Word document with Access data displayed in bookmarks.

FIGURE 6.20

A Word document with Access data displayed in bookmarks.

Check that at least one contact has been selected:

Set lst = Me![lstSelectContacts]

If lst.ItemsSelected.Count = 0 Then

MsgBox "Please select at least one contact" lst.SetFocus GoTo ErrorHandlerExit End If intColumns = lst.ColumnCount intRows = lst.ItemsSelected.Count

For Each varltem In lst.ItemsSelected

Check for required address information:

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

Debug.Print "Skipping this record -- no address!" GoTo NextContact End If strTest = Nz(lst.Column(1, varltem)) 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))

Open a new document based on the selected template:

Set appWord = GetObject(Class:="Word.Application") appWord.Documents.Add strWordTemplate

Write information to Word bookmarks, first turning off the error handler because some templates don't have all of these bookmarks:

On Error Resume Next

With appWord.Selection

.GoTo what:=wdGoToBookmark, _

Name:="NameTitleCompany" .TypeText Text:=strNameTitleCompany .GoTo what:=wdGoToBookmark, _

Name:="WholeAddress" .TypeText Text:=strWholeAddress .GoTo what:=wdGoToBookmark, Name:="Salutation" .TypeText Text:=Nz(lst.Column(10, varltem)) .GoTo what:=wdGoToBookmark, Name:="TodayDate" .TypeText Text:=strLongDate

.GoTo what:=wdGoToBookmark, _

Name:="EnvelopeNameTitleCompany" .TypeText Text:=strNameTitleCompany .GoTo what:=wdGoToBookmark, _ Name:="EnvelopeWholeAddress" .TypeText Text:=strWholeAddress .GoTo what:=wdGoToBookmark, Name:="ZipCode" .TypeText Text:=Nz(lst.Column(6, varltem)) End With

Re-insert bookmark:

With appWord.Selection .MoveLeft _

unit:=wdWord, Count:=3, _ Extend:=wdExtend .Font.Hidden = True End With

Re-hide zip code.

With ActiveDocument.Bookmarks

.Add Range:=Selection.Range, Name:="ZipCode" .DefaultSorting = wdSortByName .ShowHidden = False End With

On Error GoTo ErrorHandler

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 & " to " _

& strContactName & " - " & strCompanyName strSaveName = strSaveName & " 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) _ & " to " & strContactName & " - " _ & strCompanyName strSaveName = strSaveName & " on " _

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

Debug.Print "Save name not used: " & strSaveName intSaveNameFail = False End If NextContact: Loop

Update fields in Word document and save it:

With appWord

.Selection.WholeStory .Selection.Fields.Update .Selection.HomeKey unit:=wdStory .ActiveDocument.SaveAs strSaveNamePath End With

Next varltem

With appWord

.ActiveWindow.WindowState = wdWindowStateNormal .Visible = True .Activate End With

ErrorHandlerExit: Exit Sub

ErrorHandler:

If Err = 429 Then

'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

0 0

Post a comment