Displaying More Information about ListBox Items, Part 2

by Access Watch

| Mobile | click for more article services

Access Archon #164

The final (and most complex) procedure is the cmdWordLetters Click event procedure, which creates a new Word document from a hard-coded template for each selected contact; when it is done, the documents are open for inspection.

Private Sub cmdWordLetters_Click()

On Error GoTo ErrorHandler

Dim appWord As Word.Application

Dim doc As Word.Document

Dim strWordTemplate As String

Dim strTemplatesPath As String

Dim strDocsPath As String

Dim strFirstNameFirst As String

Dim strNameAndAddress As String

Dim strWholeAddress As String

Dim strLastNameFirst As String

Dim strSalutation As String

Dim strCompanyName As String

Dim strJobTitle As String

Dim strLastMeeting As String

Dim strLongDate As String

Dim strShortDate As String

Dim strTestFile As String

Dim prps As Object

Dim strSaveName As String

Dim i As Integer

Dim intSaveNameFail As Integer

Dim strSaveNamePath As String

Set appWord = GetObject(, "Word.Application")

strTemplatesPath = appWord.Options.DefaultFilePath(wdUserTemplatesPath) _

& "\"

Debug.Print "Templates folder: " & strTemplatesPath

strDocsPath = appWord.Options.DefaultFilePath(wdDocumentsPath) & "\"

Debug.Print "Documents folder: " & strDocsPath

strWordTemplate = "Test Letter.dot"

strWordTemplate = strTemplatesPath & "\" & strWordTemplate

strLongDate = Format(Date, "mmmm d, yyyy")

strShortDate = Format(Date, "m-d-yyyy")

   'Check for existence of template in template folder,
   'and exit if not found, with a message indicating where the
   'code is looking for the template

strTestFile = Nz(Dir(strWordTemplate))

Debug.Print "Test file: " & strTestFile

If strTestFile = "" Then

MsgBox strWordTemplate & " template not found; can't create letter"

GoTo ErrorHandlerExit

End If

'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

For Each varItem In lst.ItemsSelected

'Set variables to values from selected list item

strFirstNameFirst = Nz(lst.Column(1, varItem))

strNameAndAddress = Nz(lst.Column(2, varItem))

strWholeAddress = Nz(lst.Column(3, varItem))

strLastNameFirst = Nz(lst.Column(4, varItem))

strSalutation = Nz(lst.Column(5, varItem))

strCompanyName = Nz(lst.Column(6, varItem))

strJobTitle = Nz(lst.Column(7, varItem))

strLastMeeting = Nz(lst.Column(8, varItem))

'Create a new letter based on the selected template

Set doc = appWord.Documents.Add(strWordTemplate)

'Write long date to bookmark

doc.Bookmarks("LongDate").Select

appWord.Selection.Text = strLongDate

'Write information to Word custom document properties

Set prps = doc.CustomDocumentProperties

prps.Item("FirstNameFirst").Value = strFirstNameFirst

prps.Item("NameAndAddress").Value = strNameAndAddress

prps.Item("WholeAddress").Value = strWholeAddress

prps.Item("LastNameFirst").Value = strLastNameFirst

prps.Item("CompanyName").Value = strCompanyName

prps.Item("Salutation").Value = strSalutation

prps.Item("JobTitle").Value = strJobTitle

prps.Item("LastMeetingDate").Value = strLastMeeting

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 = "Letter to " & strFirstNameFirst

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 = "Letter " & CStr(i) & " to " & strFirstNameFirst

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 appWord

.Selection.WholeStory

.Selection.Fields.Update

.Selection.HomeKey Unit:=wdStory

.ActiveDocument.SaveAs strSaveName

End With

Next varItem

ErrorHandlerExit:

Exit Sub

ErrorHandler:

If Err = 429 Then

'Word is not running; open Word with CreateObject

Set appWord = CreateObject("Word.Application")

Resume Next

Else

MsgBox "Error No: " & Err.Number & "; Description: " _

& Err.Description

Resume ErrorHandlerExit

End If

End Sub

Notes

For information on working with document properties in Word, see my White Paper on this topic, which is included in the zip for this article.

References

The code in the sample database needs the following references (in addition to the default references):

Microsoft DAO 3.6 Object Library

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 accarch164.zip, which is the last entry in the table of Access Archon columns for Access Watch.

Document Name

Document Type

Place in

More Info ListBox (AA 164).mdb

Access 2000 database (can also be used in higher versions of Access)

Wherever you want

White Paper -- Adding Custom Doc Properties to a Word Template.doc

Word document

Wherever you want

Test Letter.dot

Word 97-2003 template

User templates folder

Article posted: Monday, 17 September 2007

there's more ...

If you liked this article you'll LOVE our new ebooks.

OFFICE 2013: the real startup guide Everything you need to know about Office 2013 but Microsoft won't tell you.

How to save money, install, configure and use the new features in Office 2013. Get it today - click here.

Windows 8 for Microsoft Office users A practical guide the new, changed and unfamiliar in Windows 8

A focused and unvarnished look at Windows 8, especially written for the many people who use Microsoft Office Get it today - click here.

ORGANIZING OUTLOOK EMAIL - tame your Outlook 2010 Inbox

100+ pages of practical tips and help to streamline, automate and search your Inbox. Get more than you ever thought possible from Outlook. Read it today - click here.