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 |
