The Type Text Method

For simple documents such as mailing labels, where you just need to insert a block of text from Access, without fancy formatting, the TypeText method of the Word Selection object can be useful. If you select the Avery 5160 (TypeText) selection from the Select Document combo box on frmMergeToWord, you will get a Word document in the form of a table with cells of the right size to print on the label sheets, as shown in Figure 6.21.

FIGURE 6.21

An Avery 5160 labels document filled with data from Access.

FIGURE 6.21

An Avery 5160 labels document filled with data from Access.

You can also create a list-type document using the TypeText method, filling a table with data from Access records, one record per row. Figure 6.22 shows such a document, the new Word 2007 table themes and the new banded rows feature.

The MergeTypeText procedure (listed as follows) writes data from variables directly to cells in a table, moving to the next cell using the MoveRight method:

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

On Error GoTo ErrorHandler using one of using one of

Dim intMod As Integer Dim lngCount As Long Dim lngSkip As Long Dim doc as Word.Document strLongDate = Format(Date, "mmmm d, yyyy") strShortDate = Format(Date, "m-d-yyyy") strDocsPath = GetContactsDocsPath() Debug.Print "Docs path: " & strDocsPath

Open a new document based on the selected labels template:

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

FIGURE 6.22

A Contact list filled with data from Access, showing new Word 2007 formatting features.

FIGURE 6.22

Determine whether the template is for labels or list, and move to the first data cell in table if needed:

If Nz(InStr(strWordTemplate, "List")) > 0 Then appWord.Selection.GoTo what:=wdGoToTable, _ which:=wdGoToFirst, _ Count:=1

appWord.Selection.MoveDown unit:=wdLine, _ Count:=1

End If

Set the intMod value depending on the number of cells per row:

strDocType = _

doc.BuiltlnDocumentProperties(wdPropertyTitle) Select Case strDocType

Case "Avery 5160 Labels" intMod = 3

Case "Avery 5161 Labels" intMod = 2

Case "Avery 5162 Labels" intMod = 2

End Select

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 information:

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 strNameTitleCompany = _

Nz(lst.Column(2, varltem)) strWholeAddress = _

Nz(lst.Column(5, varltem)) strContactName = _

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

Nz(lst.Column(7, varltem)) strJobTitle = Nz(lst.Column(8, varltem))

Process differently depending on whether the template is for labels or a list:

If Nz(InStr(strWordTemplate, "List")) > 0 Then

Insert data into list:

With appWord.Selection

.TypeText Text:=strContactName .MoveRight unit:=wdCell, Count:=1 .TypeText Text:=strJobTitle .MoveRight unit:=wdCell, Count:=1 .TypeText Text:=strCompanyName .MoveRight unit:=wdCell, Count:=1 End With

Elself Nz(InStr(strWordTemplate, "Labels")) > 0 Then lngCount = lngCount + 1

Insert data into labels, skipping narrow spacer columns:

With appWord.Selection

.TypeText Text:=strNameTitleCompany .TypeParagraph

.TypeText Text:=strWholeAddress .TypeParagraph

Use the Mod operator to handle every second or third record differently, in order to write data only to valid cells:

lngSkip = lngCount Mod intMod If lngSkip <> 0 Then

.MoveRight unit:=wdCell, Count:=2 ElseIf lngSkip = 0 Then

.MoveRight unit:=wdCell, Count:=1 End If End With End If

NextContact:

Next varltem

If Nz(InStr(strWordTemplate, "List")) > 0 Then

Delete redundant last (blank) row:

With appWord.Selection .SelectRow .Rows.Delete .HomeKey unit:=wdStory End With End If

Check for the 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

Save Word document:

appWord.ActiveDocument.SaveAs strSaveNamePath

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