Here’s the code to use to email Excel worksheets (using the Word envelope object).
Access Archon #122
Access versions: 2002 and 2003
In Part I of this article I discussed how to use the Word envelope object to email Word documents and Excel worksheets, thus avoiding the pain of attachments being stripped off by overly aggressive email security features.
The code below is the final sample procedure, used for emailing Excel worksheets.
Public Sub CreateWorksheets()
On Error GoTo ErrorHandler
Dim wks As Excel.Worksheet
Dim wkb As Excel.Workbook
Dim rng As Excel.Range
Dim strJobTitle As String
Dim strDepartment As String
Dim lngEmployeeNo As Long
Dim strSSN As String
Dim strManager As String
Dim dteTest As Date
Dim dteFrom As Date
Dim dteTo As Date
Set pappWord = GetObject(, “Word.Application”)
Set pappExcel = GetObject(, “Excel.Application”)
pappExcel.Visible = True
‘Get user templates path from Word options dialog
strTemplatePath = _
pappWord.Options.DefaultFilePath(wdUserTemplatesPath) & “”
Debug.Print “Templates folder: ” & strTemplatePath
strTemplate = strTemplatePath & “Timecard.xlt”
Debug.Print “Template: ” & strTemplate
‘Check for existence of template in template folder,
‘and exit if not found
strTestFile = Nz(Dir(strTemplate))
Debug.Print “Test file: ” & strTestFile
If strTestFile = “” Then
MsgBox strTemplate & ” template not found; can’t create worksheets”
GoTo ErrorHandlerExit
End If
‘Check that at least one contact has been checked for sending a worksheet
strQuery = “qrySendWorksheets”
strSQL = “SELECT * FROM tblContacts WHERE [SendWorksheet] = True And ” _
& “Nz([EmailName]) <> ””
Debug.Print “SQL for ” & strQuery & “: ” & strSQL
lngCount = CreateAndTestQuery(strQuery, strSQL)
Debug.Print “No. of items found: ” & lngCount
If lngCount = 0 Then
MsgBox “No contacts selected for sending worksheets; canceling”
GoTo ErrorHandlerExit
End If
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(strQuery)
With rst
Do While Not .EOF
‘Create a new worksheet based on the selected template
Set wkb = pappExcel.Workbooks.add(strTemplate)
Set wks = wkb.Sheets(1)
wks.Activate
‘Write information to cells of worksheet
strName = Trim(Nz(![FirstName]) & ” ” & Nz(![LastName]))
strEMail = Nz(![EmailName])
strJobTitle = Nz(![JobTitle])
strDepartment = “IT”
lngEmployeeNo = Nz(![ContactID])
strSSN = Nz(![SSN])
strManager = “Henry Jones”
‘Determine date of next Monday
dteTest = Date + 1
Do While Weekday(dteTest) <> vbMonday
dteTest = dteTest + 1
Debug.Print “Testing ” & dteTest
Loop
dteFrom = dteTest
‘Add 6 to get date of Sunday following next Monday
dteTo = dteTest + 6
‘Reference worksheet cells by row number, column number
Set rng = wks.Cells(10, 5)
If strName <> “” Then rng.Value = strName
Set rng = wks.Cells(11, 5)
If strJobTitle <> “” Then rng.Value = strJobTitle
Set rng = wks.Cells(12, 5)
rng.Value = strDepartment
Set rng = wks.Cells(10, 9)
If lngEmployeeNo <> 0 Then rng.Value = lngEmployeeNo
Set rng = wks.Cells(11, 9)
If strSSN <> “” Then rng.Value = strSSN
Set rng = wks.Cells(12, 9)
rng.Value = strManager
Set rng = wks.Cells(16, 5)
rng.Value = dteFrom
Set rng = wks.Cells(16, 7)
rng.Value = dteTo
‘Set envelope properties of open workbook
Debug.Print “Is envelope visible? ” & wkb.EnvelopeVisible
wkb.EnvelopeVisible = True
With wks.MailEnvelope
.Introduction = “Here is your time sheet for next week”
With .Item
.To = strEMail
.Subject = “Time sheet for ” & strName
End With
End With
.MoveNext
Loop
End With
MsgBox lngCount & ” worksheets created and ready to send”
ErrorHandlerExit:
Set pappExcel = Nothing
Exit Sub
ErrorHandler:
‘Excel is not running; open Excel with CreateObject
If Err.Number = 429 Then
Set pappExcel = CreateObject(“Excel.Application”)
Resume Next
Else
MsgBox “Error No: ” & Err.Number & “; Description: “
Resume ErrorHandlerExit
End If
End Sub
Public Function CreateAndTestQuery(strTestQuery As String, _
strTestSQL As String) As Long
On Error Resume Next
Dim qdf As DAO.QueryDef
‘Delete old query
Set dbs = CurrentDb
dbs.QueryDefs.Delete strTestQuery
On Error GoTo ErrorHandler
‘Create new query
Set qdf = dbs.CreateQueryDef(strTestQuery, strTestSQL)
‘Test whether there are any records
Set rst = dbs.OpenRecordset(strTestQuery)
With rst
.MoveFirst
.MoveLast
CreateAndTestQuery = .RecordCount
End With
ErrorHandlerExit:
Exit Function
ErrorHandler:
If Err.Number = 3021 Then
CreateAndTestQuery = 0
Resume ErrorHandlerExit
Else
MsgBox “Error No: ” & Err.Number & “; Description: ” & Err.Description
Resume ErrorHandlerExit
End If
End Function
References
The code in the sample database needs the following references (in addition to the default references):
Microsoft Office 10.0 (or 11.0) Object Library
Microsoft Word 10.0 (or 11.0) Object Library
Microsoft Excel 10.0 (or 11.0) Object Library
Microsoft DAO 3.6 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. Office XP references are v. 10.0; Office 2003 references are 11.0. The DAO reference version is the same for both. 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 accarch122.zip, which is the last entry in the table of Access Archon columns for Woody’s Access Watch.
|
Document Name |
Document Type |
Place in |
|
Envelope Object.mdb |
Access 2000 database (can also be used in Access 2002 and 2003) |
Wherever you want |
|
Test Document.dot |
Word template |
Templates folder (usually C:Program FilesMicrosoft OfficeTemplates |
|
Test Worksheet.xlt |
Excel template |
Templates folder (usually C:Program FilesMicrosoft OfficeTemplates |
