Exporting Data from Access to Outlook Items
The Outlook Data Exchange sample database has three forms that illustrate exporting data from Access tables to Outlook items, for the most commonly used items: Appointments, Contacts, Mail Messages, and Tasks. Additionally, the main menu has a set of controls for quickly creating a mail message to a recipient, and a Docs Path textbox, to allow editing the Documents path (the path is picked up from tblInfo in various procedures in the database). The first of the following two functions checks whether the path entered into the DocsPath textbox on the main menu is valid, and if so, the second function retrieves the path from tblInfo, defaulting to C:\My Documents if the field is blank. It also checks whether there is an Access Merge subfolder under the Documents folder, and creates one if needed.
Public Function CheckDocsDir() As Boolean On Error GoTo ErrorHandler Set dbs = CurrentDb Set rst = dbs.OpenRecordset("tblInfo", dbOpenDynaset) With rst .MoveFirst strFolderPath = Nz(![DocsPath]) If strFolderPath = "" Then strFolderPath = "C:\My Documents\" End If End With ‘Test the validity of the folder path Debug.Print "Folder path: " & strFolderPath If strFolderPath = "" Then strTitle = "No path entered" strPrompt = "Please enter a Docs folder path on the main menu" MsgBox strPrompt, vbOKOnly + vbCritical, strTitle CheckDocsDir = False GoTo ErrorHandlerExit Else Set fso = CreateObject("Scripting.FileSystemObject") If fso.FolderExists(strFolderPath) = False Then strTitle = "Folder path invalid" strPrompt = "Please enter a valid Docs folder path on the main menu" MsgBox strPrompt, vbOKOnly + vbCritical, strTitle GoTo ErrorHandlerExit CheckDocsDir = False End If End If CheckDocsDir = True ErrorHandlerExit: Exit Function ErrorHandler: MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End Function Public Function GetDocsDir() As String On Error GoTo ErrorHandler Dim strFolderPath As String Set dbs = CurrentDb Set rst = dbs.OpenRecordset("tblInfo", dbOpenDynaset) With rst .MoveFirst strFolderPath = Nz(![DocsPath]) If strFolderPath = "" Then strFolderPath = "C:\My Documents\" End If End With ‘Test the validity of the folder path Debug.Print "Folder path: " & strFolderPath If strFolderPath = "" Then strTitle = "No path entered" strPrompt = "Please enter a Docs folder path on the main menu" MsgBox strPrompt, vbOKOnly + vbCritical, strTitle GoTo ErrorHandlerExit Else Set fso = CreateObject("Scripting.FileSystemObject") If fso.FolderExists(strFolderPath) = False Then strTitle = "Folder path invalid" strPrompt = "Please enter a valid Docs folder path on the main menu" MsgBox strPrompt, vbOKOnly + vbCritical, strTitle GoTo ErrorHandlerExit End If End If strDocsDir = strFolderPath & "Access Merge\" Debug.Print "Access Merge subfolder: " & strDocsDir ‘Test for existence of Access Merge subfolder, and create ‘it if it is not found Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FolderExists(strDocsDir) Then ‘Access Merge subfolder does not exist; create it fso.CreateFolder strDocsDir End If GetDocsDir = strDocsDir ErrorHandlerExit: Exit Function ErrorHandler: MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End Function
The CheckDocsDir and GetDocsDir functions are used whenever the code in the Outlook Data Exchange sample database needs to save a document (in this database, the documents are the saved reports to be attached to mail messages), using the following code segment:
If CheckDocsDir = False Then GoTo ErrorHandlerExit End If strDocsPath = GetDocsDir
Creating a Mail Message from the Main Menu
The main menu of the Outlook Data Exchange database has a section where you can type the subject and message text of an email message, select a recipient from tblContacts (a table of contact data with an EMailName field), and send a message to the recipient by clicking the large EMail command button. The main menu is shown in Figure 12.6, with a recipient selected.
Figure 12.6
The AfterUpdate event procedure for the large EMail command button is listed below, with explanatory text.
Private Sub cmdEMail_Click() On Error GoTo ErrorHandler Dim strEMailRecipient As String Dim dteLastMeeting As Date Dim strSubject As String Dim strMessage As String Dim strBody As String
This variable represents an Outlook folder—note that the object name is not Folder, but MAPIFolder.
Dim fld As Outlook.MAPIFolder Dim msg As Outlook.MailItem
Check the Access table record for required email information. The information is picked up from columns of the selected record in the combobox, using the zero-based Column (n) syntax.
strEMailRecipient = Nz(Me![cboRecipients].Column(1)) If strEMailRecipient = "" Then GoTo ErrorHandlerExit Else
A Debug.Print statement is useful for debugging.
Debug.Print "EMail recipient: " & strEMailRecipient End If dteLastMeeting = CDate(Me![cboRecipients].Column(2))
The Nz function is used to set the strSubject variable to “Reminder” in case nothing has been entered into the MessageSubject field.
strSubject = Nz(Me![MessageSubject], "Reminder") The Nz function is initially used to set the strMessage variable to a zero-length string (“”) if nothing has been entered into the MessageSubject field (to prevent errors with Nulls).
strMessage = Nz(Me![MessageText]) If strMessage <> "" Then strBody = strMessage Else
If nothing was entered, a message including the last meeting date is created.
strBody = "Your last meeting was on " & dteLastMeeting & "; please call to arrange a meeting by the end of the year." End If
A new mail message is created, working down from the Outlook Application object, to the NameSpace object, then to the Outbox folder, and the Add method of its Items collection.
Set gappOutlook = GetObject(, Outlook.Application) Set nms = gappOutlook.GetNamespace("MAPI") Set fld = nms.GetDefaultFolder(olFolderOutbox) Set msg = fld.Items.Add
Various properties of the new mail message are set, and it is sent.
With msg .To = strEMailRecipient .Subject = strSubject .Body = strBody .Send End With ErrorHandlerExit: Exit Sub ErrorHandler:
This error handler runs the CreateObject function to create an Outlook instance, in case Outlook is not running.
If Err = 429 Then ‘Outlook is not running; open Outlook with CreateObject. Set gappOutlook = CreateObject("Outlook.Application") Resume Next Else MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End If End Sub
When you click the EMail button, you will probably see the message shown in Figure 12.7. This is part of the obnoxious Object Model Guardian that appears when you access Outlook mail messages and contacts.
Figure 12.7
To create the message, click the Yes button in this dialog. For a way of avoiding the Object Model Guardian dialog, see the section, “Using the Redemption Library to Avoid the Object Model Guardian,” later in this chapter.
A mail message created by this procedure is shown in Figure 12.8.
Figure 12.8
MultiSelect Listbox Form
For creating various types of Outlook items, with data from multiple records in an Access table, I created frmExportToOutlookListBox, which uses a MultiSelect listbox as a way of selecting multiple records from a table, with a combobox in the header for selecting an Outlook item type. The cboSelectOutlookItem combobox has as its row source the table tlkpOutlookItemTypes, which follows.
| ItemTypeID | ItemType | ItemConstant | DataSource |
|---|---|---|---|
| 0 | Mail message | olMailItem | qryContactsEMail |
| 1 | Appointment | olAppointmentItem | qryAppointments |
| 2 | Contact | olContactItem | qryContacts |
| 3 | Task | olTaskItem | qryTasks |
Information from different columns in the selected row of the table is used in the code on the combobox’s AfterUpdate event and the Create Items command button in the form footer. Figure 12.9 shows the listbox dialog, with Contact selected as the Outlook item type.
Figure 12.9
For the Contact selection, qryContacts is assigned as the row source of lstSelectMultiple; this query displays data from tblContacts. The code for cboSelectOutlookItem’s AfterUpdate event procedure follows, with commentary.
Private Sub cboSelectOutlookItem_AfterUpdate() On Error GoTo ErrorHandler
Set a variable for the listbox.
Set lst = Me![lstSelectMultiple] Set variables representing the data in different columns of the listbox.
lngItemId = Me![cboSelectOutlookItem].Column(0) strItemType = Me![cboSelectOutlookItem].Column(1) strItemConstant = Me![cboSelectOutlookItem].Column(2) strDataSource = Me![cboSelectOutlookItem].Column(3)
Assign the appropriate data source as the listbox’s row source.
lst.RowSource = strDataSource For mail messages only, enable the txtMessageText textbox.
If lngItemId = 0 Then ‘Mail message selected Me![txtMessageText].Enabled = True Else Me![txtMessageText].Enabled = False End If
Set up a Select Case statement to set the appropriate number of columns, and column sizes, for each data source.
Select Case strDataSource Case "qryContacts" lst.ColumnCount = 13 lst.ColumnWidths = "0 in;1.25 in;1.25 in;1 in;.6 in;.6 in;0 in;0 in;0 in;0 in;0 in;0 in;0 in" Case "qryAppointments" lst.ColumnCount = 8 lst.ColumnWidths = "0 in;1.25 in;1.25 in;1.5 in;1.5 in;0 in;1.25 in;1.25 in" Case "qryTasks" lst.ColumnCount = 7 lst.ColumnWidths = "0 in;1.5 in;0 in;1.25 in;1 in;1 in;.75 in" Case "qryContactsEMail" lst.ColumnCount = 5 lst.ColumnWidths = "0 in;1.25 in;1.25 in;1.75 in;1.25 in" End Select ErrorHandlerExit: Exit Sub ErrorHandler: MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End Sub
As a quick way of selecting all the records, the Select All button in the form footer iterates through all the rows in the listbox, setting the Selected property of each row to True. This procedure is:
Private Sub cmdSelectAll_Click() On Error GoTo ErrorHandler
Set a variable to the listbox.
Set lst = Me![lstSelectMultiple] Count the number of rows in the listbox, and save this number to a variable.
intRows = lst.ListCount - 1 Select all the rows in the listbox.
For intIndex = 0 To intRows lst.Selected(intIndex) = True Next intIndex ErrorHandlerExit: Exit Sub ErrorHandler: MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End Sub
The main procedure on the listbox form is the Click event procedure of cmdCreateItems, which follows, with explanatory text.
Private Sub cmdCreateItems_Click() On Error GoTo ErrorHandler
Declare variables for values from the Access tables, Outlook objects, and listbox rows and columns.
Dim strContactName As String Dim strTaskName As String Dim dteStartDate As Date Dim dteDueDate As Date Dim strStatus As String Dim lngStatus As Long Dim strSalutation As String Dim strPostalCode As String Dim strStateProv As String Dim strCity As String Dim strStreetAddress As String Dim nms As Outlook.NameSpace Dim fldCalendar As Outlook.MAPIFolder Dim fldContacts As Outlook.MAPIFolder Dim fldTasks As Outlook.MAPIFolder Dim appt As Outlook.AppointmentItem Dim msg As Outlook.MailItem Dim con As Outlook.ContactItem Dim tsk As Outlook.TaskItem Dim lnks As Outlook.Links Dim itm As Object Dim blnSomeSkipped As Boolean Dim cbo As Access.ComboBox Dim dbs As DAO.Database Dim dteLastMeeting As Date Dim i As String Dim lngAppointmentID As Long Dim lngContactID As Long Dim strBody As String Dim strCompanyName As String Dim strCountry As String Dim strDocName As String Dim strDocsPath As String Dim strDocType As String Dim strEMailRecipient As String Dim strFullName As String Dim strFile As String Dim strJobTitle As String Dim strLongDate As String Dim strMessage As String Dim strName As String Dim strNameAndJob As String Dim strPrompt As String Dim strShortDate As String Dim strSubject As String Dim strTest As String Dim strTestFile As String Dim strTextFile As String Dim strTitle As String Dim varItem As Variant
Check that an Outlook item type has been selected, and exit if it has not.
Set cbo = Me![cboSelectOutlookItem] Set lst = Me![lstSelectMultiple] lngItemId = Nz(cbo.Column(0)) strItemType = Nz(cbo.Column(1)) Debug.Print "Selected Outlook item type: " & strItemType If strItemType = "" Then MsgBox "Please select an Outlook item type." cbo.SetFocus cbo.Dropdown GoTo ErrorHandlerExit End If
Check that at least one record has been selected in the listbox, and exit if it has not.
If lst.ItemsSelected.Count = 0 Then MsgBox "Please select at least one record." lst.SetFocus GoTo ErrorHandlerExit Else intColumns = lst.ColumnCount intRows = lst.ItemsSelected.Count End If
Set a global Outlook application variable; if Outlook is not running, the error handler defaults to CreateObject.
Set gappOutlook = GetObject(, "Outlook.Application") Open a text file for writing information about skipped records.
strFile = strDocsPath & "Skipped Records.txt" Open strFile For Output As #1 Print #1, "These records were skipped when creating Outlook items" Print #1,
Set up a Select Case statement to deal with each Outlook item type.
Select Case strItemType Case "Mail message"
Set blnSomeSkipped to False to start with—it will be set to True if any records have to be skipped because of missing data.
blnSomeSkipped = False Set up a For Each . . . Next loop to deal with each selected item in the listbox, using the handy Access ItemsSelected collection.
For Each varItem In lst.ItemsSelected Get the Contact ID for use later in the code.
lngContactID = Nz(lst.Column(0, varItem)) Debug.Print "Contact ID: " & lngContactID
Check for required email information, and set blnSomeSkipped to True if anything is missing.
strTest = Nz(lst.Column(3, varItem)) Debug.Print "Email address: " & strTest If strTest = "" Then blnSomeSkipped = True
Print a line about the missing information to the Skipped Records text file.
Print #1, Print #1, "No email address for Contact " & lngContactID GoTo NextItemMail End If
As with the main menu, either pick up the message text from the MessageText field in tblInfo or create a message about the last meeting date.
strEMailRecipient = Nz(lst.Column(3, varItem)) dteLastMeeting = Nz(lst.Column(4, varItem)) strMessage = Nz(Me![MessageText]) If strMessage <> "" Then strBody = strMessage Else strBody = "Your last meeting was on " & dteLastMeeting & "; please call to arrange a meeting by the end of the year." End If
Create the new mail message, using the CreateItem method of the Application object, and set the values of several of its fields. The new item will be created in the default folder for mail messages (the Outbox).
Set gappOutlook = GetObject(, Outlook.Application) Set msg = gappOutlook.CreateItem(olMailItem) With msg .To = strEMailRecipient .Subject = "Meeting reminder" .Body = strBody .Send End With
Go the next record.
NextItemMail: Next varItem
When all the selected records have been processed, put up an informative message box.
strTitle = "Done" If blnSomeSkipped = True Then strPrompt = "All mail messages created; some records skipped because " & "of missing information." & vbCrLf & "See " & strDocsPath & "Skipped Records.txt for details." Else strPrompt = "All mail messages created!" End If MsgBox strPrompt, vbOKOnly + vbInformation, strTitle Case "Appointment"
Much of the code is similar to the mail message code; only segments that differ will be explained in detail.
blnSomeSkipped = False For Each varItem In lst.ItemsSelected ‘Get Appointment ID for reference lngAppointmentID = Nz(lst.Column(0, varItem)) Debug.Print "Appointment ID: " & lngAppointmentID ‘Check for required appointment information. strTest = Nz(lst.Column(1, varItem)) Debug.Print "Topic: " & strTest If strTest = "" Then blnSomeSkipped = True Print #1, Print #1, "No topic for Appointment " & lngAppointmentID GoTo NextItemAppt Else strSubject = lst.Column(1, varItem) End If strTest = Nz(lst.Column(3, varItem)) Debug.Print "Start time: " & strTest If strTest = "" Then blnSomeSkipped = True Print #1, Print #1, "No start time for Appointment " & lngAppointmentID GoTo NextItemAppt End If ‘Create new appointment in default Calendar folder Set gappOutlook = GetObject(, Outlook.Application) Set nms = gappOutlook.GetNamespace("MAPI") Set appt = gappOutlook.CreateItem(olAppointmentItem) With appt .Subject = strSubject dteStartDate = Nz(lst.Column(3, varItem)) .Start = dteStartDate If IsDate(lst.Column(4, varItem)) = True Then dteEndDate = lst.Column(4, varItem) .End = dteEndDate End If .Location = Nz(lst.Column(2, varItem)) .Categories = Nz(lst.Column(7, varItem))
Appointments can have one or more contacts, which are stored in the Links collection of the AppointmentItem object. To add a contact to an appointment, first the contact is located in a Contacts folder (here the default local Contacts folder is searched), and then the ContactItem is added to the Links collection.
If Nz(lst.Column(5, varItem)) > 0 Then ‘There is a contact for this appointment; attempt to ‘locate this contact in the default Contacts folder. Set nms = gappOutlook.GetNamespace("MAPI") Set fldContacts = nms.GetDefaultFolder(olFolderContacts) On Error Resume Next lngContactID = Nz(lst.Column(5, varItem)) ‘Find the contact, using the CustomerID field Set con = fldContacts.Items.Find("[CustomerID] = " & lngContactID) If con Is Nothing Then strPrompt = "Can’t find Contact ID " & lngContactID & " in your default local Contacts folder" Debug.Print strPrompt Else Set lnks = .Links lnks.Add con End If On Error GoTo ErrorHandler End If .Close(olSave) End With NextItemAppt: Next varItem strTitle = "Done" If blnSomeSkipped = True Then strPrompt = "All appointments created; some records skipped because " & "of missing information." & vbCrLf & "See " & strDocsPath & "Skipped Records.txt for details." Else strPrompt = "All appointments created!" End If MsgBox strPrompt, vbOKOnly + vbInformation, strTitle Case "Contact" blnSomeSkipped = False For Each varItem In lst.ItemsSelected ‘Get Contact ID for reference lngContactID = Nz(lst.Column(0, varItem)) Debug.Print "Contact ID: " & lngContactID ‘Check for required name information strTest = Nz(lst.Column(1, varItem)) Debug.Print "Contact name: " & strTest If strTest = "" Then blnSomeSkipped = True Print #1, Print #1, "No name for Contact " & lngContactID GoTo NextItemContact End If strFullName = Nz(lst.Column(7, varItem)) strJobTitle = Nz(lst.Column(10, varItem)) strStreetAddress = Nz(lst.Column(2, varItem)) strCity = Nz(lst.Column(3, varItem)) strStateProv = Nz(lst.Column(4, varItem)) strPostalCode = Nz(lst.Column(5, varItem)) strCountry = Nz(lst.Column(6, varItem)) strCompanyName = Nz(lst.Column(9, varItem)) strSalutation = Nz(lst.Column(11, varItem)) strEMailRecipient = Nz(lst.Column(12, varItem)) ‘Create new contact item in default local Contacts folder Set gappOutlook = GetObject(, Outlook.Application) Set con = gappOutlook.CreateItem(olContactItem) With con .CustomerID = lngContactID .FullName = strFullName .JobTitle = strJobTitle .BusinessAddressStreet = strStreetAddress .BusinessAddressCity = strCity .BusinessAddressState = strStateProv .BusinessAddressPostalCode = strPostalCode .BusinessAddressCountry = strCountry .CompanyName = strCompanyName .NickName = strSalutation .Email1Address = strEMailRecipient .Close(olSave) End With NextItemContact: Next varItem strTitle = "Done" If blnSomeSkipped = True Then strPrompt = "All contacts created; some records skipped because " & "of missing information." & vbCrLf & "See " & strDocsPath & "Skipped Records.txt for details." Else strPrompt = "All contacts created!" End If MsgBox strPrompt, vbOKOnly + vbInformation, strTitle Case "Task" blnSomeSkipped = False For Each varItem In lst.ItemsSelected ‘Check for required task information strTest = Nz(lst.Column(1, varItem)) Debug.Print "Task: " & strTest If strTest = "" Then blnSomeSkipped = True Print #1, Print #1, "No task name" GoTo NextItemTask End If strTaskName = Nz(lst.Column(1, varItem)) lngContactID = Nz(lst.Column(2, varItem)) dteStartDate = Nz(lst.Column(4, varItem)) dteDueDate = Nz(lst.Column(5, varItem)) strStatus = Nz(lst.Column(6, varItem)) lngStatus = Switch(strStatus = "Not started", 0, strStatus = "In progress", 1, strStatus = "Completed", 2, "", 0) ‘Create new task item in default local Tasks folder Set gappOutlook = GetObject(, Outlook.Application) Set tsk = gappOutlook.CreateItem(olTaskItem) With tsk .Subject = strTaskName .StartDate = dteStartDate .DueDate = dteDueDate .Status = lngStatus
Tasks can have one or more contacts, which are stored in the Links collection of the TaskItem object. To add a contact to a task, first the contact is located in a Contacts folder (here the default local Contacts folder is searched), and then the ContactItem is added to the Links collection.
If lngContactID > 0 Then ‘There is a contact for this appointment; attempt to ‘locate this contact in the default Contacts folder. Set nms = gappOutlook.GetNamespace("MAPI") Set fldContacts = nms.GetDefaultFolder(olFolderContacts) ‘Find contact, using the Subject field Set con = fldContacts.Items.Find("[Subject] = " & strSubject) If con Is Nothing Then strPrompt = "Can’t find Contact ID " & lngContactID & " in your default local Contacts folder" Debug.Print strPrompt Else Set lnks = .Links lnks.Add con End If .Close(olSave) End With NextItemTask: Next varItem strTitle = "Done" If blnSomeSkipped = True Then strPrompt = "All tasks created; some records skipped because " & "of missing information." & vbCrLf & "See " & strDocsPath & "Skipped Records.txt for details." Else strPrompt = "All tasks created!" End If MsgBox strPrompt, vbOKOnly + vbInformation, strTitle End Select ErrorHandlerExit: Close #1 Exit Sub ErrorHandler: If Err = 429 Then ‘Outlook is not running; open Outlook with CreateObject Set gappOutlook = CreateObject("Outlook.Application") Resume Next Else MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End If End Sub
Figure 12.10 shows an appointment (with a contact) created from one of the records in tblAppointments.
Figure 12.10
Datasheet Form
While the listbox form lets you select multiple Access records for creating Outlook items, you may realize that it has some limitations. It is easy to select all the records in a table, or just a few records selected on an ad hoc basis, but it isn’t easy to select large numbers of filtered records—say, creating contact items for all contacts in the state of Idaho. There is no way to do this kind of selection in a listbox, so I made another form, with a datasheet subform, to make it possible to select records using a filter. frmExportToOutlookDatasheet is shown in its initial state in Figure 12.11.
Figure 12.11
As with the listbox form, selecting an Outlook item type from cboSelectOutlookItem selects the appropriate data source, in this case by making one subform visible and the others invisible (each record source has its own subform). cboSelectOutlookItem’s AfterUpdate event procedure follows.
Private Sub cboSelectOutlookItem_AfterUpdate() On Error GoTo ErrorHandler Me![txtFilterString].Value = Null Me![txtSelectedFolder].Value = Null plngItemId = Me![cboSelectOutlookItem].Column(0) pstrItemType = Me![cboSelectOutlookItem].Column(1) pstrItemConstant = Me![cboSelectOutlookItem].Column(2) pstrDataSource = Me![cboSelectOutlookItem].Column(3) pstrQuery = Nz(Me![cboSelectOutlookItem].Column(3)) & "Alpha" If plngItemId <> 0 Then Me![cmdSelectOutlookFolder].Enabled = True Else Me![cmdSelectOutlookFolder].Enabled = False End If If plngItemId = 0 Then ‘Mail message selected Me![txtMessageText].Enabled = True Else Me![txtMessageText].Enabled = False End If Select Case pstrDataSource Case "qryContacts" Me![subContacts].Visible = True Me![subContacts].Locked = True Me![subAppointments].Visible = False Me![subTasks].Visible = False Me![subEMail].Visible = False Case "qryAppointments" Me![subContacts].Visible = False Me![subAppointments].Visible = True Me![subAppointments].Locked = True Me![subTasks].Visible = False Me![subEMail].Visible = False Case "qryTasks" Me![subContacts].Visible = False Me![subAppointments].Visible = False Me![subTasks].Visible = True Me![subTasks].Locked = True Me![subEMail].Visible = False Case "qryContactsEMail" Me![subContacts].Visible = False Me![subAppointments].Visible = False Me![subTasks].Visible = False Me![subEMail].Visible = True Me![subEMail].Locked = True End Select Me![cboFilterField].Value = Null Me![cboFilterValue].Value = Null Me![cboFilterField].RowSource = pstrDataSource & "Alpha" Me![fraRecords].Enabled = True ErrorHandlerExit: Exit Sub ErrorHandler: MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End Sub
This procedure also enables the fraRecords option group, where you can select All Records or Filtered Records, and clears the two comboboxes used to select a filter.
Initially, on selecting an Outlook item type, all records are displayed. If you want to filter the records, click Filtered Records in the Records option group. The AfterUpdate procedure of this option group enables the Filter field combobox and sets its row source to the appropriate query. This procedure follows, with commentary for the first Case statement (the others are similar).
Private Sub fraRecords_AfterUpdate() On Error GoTo ErrorHandler Dim intRecords As Integer
Call a procedure that clears the source objects of all the subforms and the values of the filter controls.
Call ClearList Set a variable representing the choice in fraRecords.
intRecords = Nz(Me![fraRecords].Value, 1) Set up a Select Case statement for the selected data source (the public variable pstrDataSource was set by the selection in cboSelectOutlookItemType).
Select Case pstrDataSource Case "qryContacts"
Make the subContacts subform visible, and the other subforms invisible.
Me![subContacts].Visible = True Me![subContacts].Locked = True Me![subAppointments].Visible = False Me![subTasks].Visible = False Me![subEMail].Visible = False If intRecords = 1 Then
If All Records was selected in the Records option group, make fsubContactsAll the source object of subContacts, and disable the filter controls.
Me![subContacts].SourceObject = "fsubContactsAll" Me![cboFilterField].Enabled = False Me![cboFilterField].Value = "" Me![cboFilterValue].Enabled = False ElseIf intRecords = 2 Then
If Filtered Records was selected in the Records option group, clear the source object of subContacts (it will be set later, after making filter selections), and enable cboFilterField.
Me![subContacts].SourceObject = "" Me![cboFilterField].Enabled = True Me![cboFilterField].Value = "" Me![cboFilterValue].Enabled = False End If Case "qryAppointments" Me![subContacts].Visible = False Me![subAppointments].Visible = True Me![subAppointments].Locked = True Me![subTasks].Visible = False Me![subEMail].Visible = False If intRecords = 1 Then Me![subAppointments].SourceObject = "fsubAppointmentsAll" Me![cboFilterField].Enabled = False Me![cboFilterField].Value = "" Me![cboFilterValue].Enabled = False ElseIf intRecords = 2 Then Me![subAppointments].SourceObject = "" Me![cboFilterField].Enabled = True Me![cboFilterField].Value = "" Me![cboFilterValue].Enabled = False End If Case "qryTasks" Me![subContacts].Visible = False Me![subAppointments].Visible = False Me![subTasks].Visible = True Me![subTasks].Locked = True Me![subEMail].Visible = False If intRecords = 1 Then Me![subTasks].SourceObject = "fsubTasksAll" Me![cboFilterField].Enabled = False Me![cboFilterField].Value = "" Me![cboFilterValue].Enabled = False ElseIf intRecords = 2 Then Me![subTasks].SourceObject = "" Me![cboFilterField].Enabled = True Me![cboFilterField].Value = "" Me![cboFilterValue].Enabled = False End If Case "qryContactsEMail" Me![subContacts].Visible = False Me![subAppointments].Visible = False Me![subTasks].Visible = False Me![subEMail].Visible = True Me![subEMail].Locked = True If intRecords = 1 Then Me![subEMail].SourceObject = "fsubEmailAll" Me![cboFilterField].Enabled = False Me![cboFilterField].Value = "" Me![cboFilterValue].Enabled = False ElseIf intRecords = 2 Then Me![subEMail].SourceObject = "" Me![cboFilterField].Enabled = True Me![cboFilterField].Value = "" Me![cboFilterValue].Enabled = False End If End Select ErrorHandlerExit: Exit Sub ErrorHandler: MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End Sub
Using public variables set from the user’s initial selection in cboSelectOutlookItemType lets me clear this combobox, but preserve the selected values for use in code running from other controls. I could also save the selection to tblInfo, but in this case, public variables work fine. Saving to tblInfo would be required if I need to preserve the values from one database session to another, or if I want to easily check their values for debugging purposes.
On selecting a field for filtering from cboFilterField, the public variable pstrFilterField is set, and a SQL statement is constructed, using the public variables pstrQuery and pstrFilterField. The SQL statement is assigned as the row source of cboFilterValue, that combobox is requeried, and its list is dropped down. Finally, the make-table query and the table it makes are deleted (if they exist). This procedure follows.
Private Sub cboFilterField_AfterUpdate() On Error GoTo ErrorHandler pstrFilterField = Nz(Me![cboFilterField].Value) If pstrFilterField = "" Then strTitle = "No field selected" strPrompt = "Please select a field for filtering" MsgBox strPrompt, vbCritical + vbOKOnly, strTitle Me![cboFilterField].SetFocus GoTo ErrorHandlerExit End If strSQL = "SELECT DISTINCT " & pstrQuery & ".[" & pstrFilterField & "] FROM " & pstrQuery & " WHERE [" & pstrFilterField & "] Is Not Null;" Debug.Print "SQL string: " & strSQL With Me![cboFilterValue] .Value = Null .RowSource = strSQL .Requery .Enabled = True .SetFocus .Dropdown End With Me![txtFilterString].Value = Null Call ClearTables ErrorHandlerExit: Exit Sub ErrorHandler: MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End Sub
The AfterUpdate procedure of cboFilterValue is more complex; it follows, with commentary.
Private Sub cboFilterValue_AfterUpdate() On Error GoTo ErrorHandler Dim intDataType As Integer Dim fld As DAO.Field Dim qdf As DAO.QueryDef Dim strTotalsQuery As String Dim strLinkedQuery As String Dim strFilter As String
Set a public variable to the selected filter value.
pvarFilterValue = Me![cboFilterValue].Value Debug.Print "Selected value: " & pvarFilterValue
Determine the data type of the selected field.
Set dbs = CurrentDb Set rst = dbs.OpenRecordset(pstrQuery, dbOpenDynaset) Set fld = rst.Fields(pstrFilterField) intDataType = fld.Type Debug.Print "Field data type: " & intDataType
Set up a Select Case statement to create an appropriate filter string for different data types.
Select Case intDataType Case 1 ‘Boolean strFilter = "[" & pstrFilterField & "] = " & pvarFilterValue Case 2, 3, 4, 6, 7 ‘Various numeric strFilter = "[" & pstrFilterField & "] = " & pvarFilterValue Case 5 ‘Currency
Use CCur to make sure the value is passed as a Currency value.
strFilter = "[" & pstrFilterField & "] = " & CCur(pvarFilterValue) Case 8 ‘Date
Wrap the value in # characters.
strFilter = "[" & pstrFilterField & "] = " & Chr$(35) & pvarFilterValue & Chr$(35) Case 10 ‘Text
Wrap the value in double quotes.
strFilter = "[" & pstrFilterField & "] = " & Chr$(34) & pvarFilterValue & Chr$(34) Case 11, 12, 15 ‘OLE object, Memo, Replication ID
Inform the user that you can’t filter by this type of field.
strPrompt = "Can’t filter by this field; please select another field" MsgBox strPrompt, vbCritical + vbOKOnly Me![cboFilterValue].SetFocus Me![cboFilterValue].Dropdown GoTo ErrorHandlerExit End Select
Display the filter string just created in the Immediate window for purposes of debugging.
Debug.Print "Filter string: " & strFilter Write the filter string to a locked textbox on the form.
Me![txtFilterString] = strFilter Apply the filter to the selected record source and make a table from it, using a SQL statement to create the make-table query. Making a table rather than just using the query as the subform’s source object allows deletion of records on the subform, without affecting the underlying data.
strQuery = "qmakMatchingRecords" strSQL = "SELECT " & pstrQuery & ".* INTO tmakMatchingRecords " & "FROM " & pstrQuery & " WHERE " & strFilter & ";" Debug.Print "SQL Statement: " & strSQL Set qdf = dbs.CreateQueryDef(strQuery, strSQL) qdf.Execute Me![cboFilterField].Value = Null Me![cboFilterValue].Value = Null
Display the selected data source name to the Immediate window for purposes of debugging.
Debug.Print "Data source: " & pstrDataSource Set up a Select Case statement to select the appropriate filtered subform as the selected subform’s source object. The filtered subforms have the table made by the make-table query earlier (tmakMatchingRecords) as their record source.
Select Case pstrDataSource Case "qryContacts" Me![subContacts].SourceObject = "fsubContactsFiltered" Debug.Print "subContacts source object: " & Me![subContacts].SourceObject Case "qryAppointments" Me![subAppointments].SourceObject = "fsubAppointmentsFiltered" Debug.Print "subAppointments source object: " & Me![subAppointments].SourceObject Case "qryTasks" Me![subTasks].SourceObject = "fsubTasksFiltered" Debug.Print "subTasks source object: " & Me![subTasks].SourceObject Case "qryContactsEMail" Me![subEMail].SourceObject = "fsubEMailFiltered" Debug.Print "subEMail source object: " & Me![subEMail].SourceObject End Select ErrorHandlerExit: Exit Sub ErrorHandler: MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End Sub
Figure 12.12 shows contacts filtered by state.
Figure 12.12
The listbox form automatically created items in the default local Contacts, Tasks, Calendar, or Outbox folder. The datasheet form lets you select a folder for creating items. To select an Outlook folder (this option is available for Appointments, Contacts, and Tasks), click the Select Outlook folder command button in the form header. The Click event procedure on this form (listed below) pops up the Outlook Select Folder dialog (shown in Figure 12.13), where you can select a folder. Unfortunately, there is no way to filter this dialog so that it offers all the Outlook folders on your system, whether they are the right type or not. You can’t create contacts in a Tasks folder or vice versa, so the code checks the folder type by examining its DefaultItemType property to see whether it matches the item type selected in the cboSelectOutlookItemType combobox. (The exception is mail messages, which are always created in the Outbox—or the Drafts folder, if you are using the Redemption Library; the Select Outlook folder command button is disabled if you select Mail message as the Outlook item type.)
Private Sub cmdSelectOutlookFolder_Click() On Error GoTo ErrorHandler Dim nms As Outlook.NameSpace Set gappOutlook = GetObject(, Outlook.Application) Set nms = gappOutlook.GetNamespace("MAPI") SelectFolder:
Set a public variable to the selected folder. This is the actual folder object itself, not the folder name.
Set pfld = nms.PickFolder If pfld Is Nothing Then GoTo ErrorHandlerExit End If
Test whether folder is the right type for the selected Outlook item type.
Debug.Print "Default item type: " & pfld.DefaultItemType If pfld.DefaultItemType <> plngItemId Then MsgBox "Please select a " & pstrItemType & " folder" GoTo SelectFolder End If
Display the name of the selected folder in a textbox on the form.
pstrFolderName = pfld.Name Me![txtSelectedFolder].Value = pstrFolderName ErrorHandlerExit: Exit Sub ErrorHandler: If Err = 429 Then ‘Outlook is not running; open Outlook with CreateObject. Set gappOutlook = CreateObject("Outlook.Application") Resume Next Else MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End If End Sub
Figure 12.13
Figure 12.14 shows the Contacts from Access folder, with the Utah contacts exported from Access.
Figure 12.14
The Create Items command button does the work of creating the items, in the selected folder. Its procedure is similar to that of the button on the listbox form, except that instead of picking up data from columns of a listbox, it uses a DAO recordset to pick up data from fields of a query or table. The cmdCreateItems Click event procedure follows, with commentary.
Private Sub cmdCreateItems_Click() On Error GoTo ErrorHandler
Declare variables for values from the Access tables, Outlook objects, and DAO objects for working with recordsets.
Dim blnSomeSkipped As Boolean Dim dteDueDate As Date Dim dteEndDate As Date Dim dteEndTime As Date Dim dteLastMeeting As Date Dim dteStartDate As Date Dim dteStartTime As Date Dim fldContacts As Outlook.MAPIFolder Dim intRecords As Integer Dim lngAppointmentID As Long Dim lngContactID As Long Dim lngStatus As Long Dim lnks As Outlook.Links Dim rstData As DAO.Recordset Dim strBody As String Dim strCity As String Dim strCompanyName As String Dim strContactName As String Dim strCountry As String Dim strEMailRecipient As String Dim strFile As String Dim strFullName As String Dim strJobTitle As String Dim strMessage As String Dim strMessageText As String Dim strPostalCode As String Dim strSalutation As String Dim strStateProv As String Dim strStatus As String Dim strStreetAddress As String Dim strSubject As String Dim strTaskName As String Dim strTest As String Dim strTestFile As String
Check that an Outlook item type has been selected, and exit if it has not.
Debug.Print "Selected item type: " & pstrItemType If pstrItemType = "" Then Me![cboSelectOutlookItem].SetFocus Me![cboSelectOutlookItem].Dropdown MsgBox "Please select an Outlook item type", vbCritical GoTo ErrorHandlerExit End If intRecords = Me![fraRecords].Value strMessageText = Nz(Me![MessageText])
Set a global Outlook application variable; if Outlook is not running, the error handler defaults to CreateObject.
Set gappOutlook = GetObject(, "Outlook.Application") Set nms = appOutlook.GetNamespace("MAPI")
Open a text file for writing information about skipped records.
strFile = strDocsPath & "Skipped Records.txt" Open strFile For Output As #1 Print #1, "These records were skipped when creating documents" Print #1,
Determine what type of Outlook item is to be used, what Outlook folder is to be used, and whether all records or filtered records are to be merged.
Debug.Print "Data source: " & pstrDataSource If Me![fraRecords].Value = 2 Then
Filtered records—change data source to the filtered table.
pstrDataSource = "tmakMatchingRecords" Else
For the All Records selection, keep the selection made in cboSelectOutlookItem.
End If
Set up a Select Case statement to set the global pfld variable appropriately for each item type, in case a specific folder is not selected.
Select Case plngItemId Case 0 Set pfld = nms.GetDefaultFolder(olFolderOutbox) pstrFolderName = "Outbox" Case 1 pstrFolderName = "Calendar" Set pfld = nms.GetDefaultFolder(olFolderCalendar) Case 2 pstrFolderName = "Contacts" Set pfld = nms.GetDefaultFolder(olFolderContacts) Case 3 pstrFolderName = "Tasks" Set pfld = nms.GetDefaultFolder(olFolderTasks) End Select Debug.Print "Selected folder: " & pstrFolderName
Set up a DAO recordset based on the selected data source.
Set dbs = CurrentDb Set rstData = dbs.OpenRecordset(pstrDataSource, dbOpenDynaset)
Set up a Select Case statement to deal with each Outlook item type.
Select Case pstrItemType Case "Appointment"
Set blnSomeSkipped to False to start with—it will be set to True if any records have to be skipped because of missing data.
blnSomeSkipped = False Set up a For Each . . . Next loop to deal with each item in the datasheet.
With rstData Do While Not .EOF
Get the Appointment ID use later in the code.
lngAppointmentID = Nz(![AppointmentID]) Debug.Print "Appointment ID: " & lngAppointmentID
Check for required appointment information, and set blnSomeSkipped to True if anything is missing.
strTest = Nz(![Topic]) Debug.Print "Topic: " & strTest If strTest = "" Then blnSomeSkipped = True Print #1, Print #1, "No topic for Appointment " & lngAppointmentID GoTo NextItemAppt Else strSubject = Nz(![Topic]) End If strTest = Nz(![StartTime]) Debug.Print "Start time: " & strTest If strTest = "" Then blnSomeSkipped = True
Print a line about the missing information to the Skipped Records text file.
Print #1, Print #1, "No start time for Appointment " & lngAppointmentID GoTo NextItemAppt End If
Create a new appointment in the selected folder.
Set appt = pfld.Items.Add appt.Subject = strSubject
Write StartTime and EndTime properties only if there is a valid date in the corresponding Access table fields.
If IsDate(![StartTime]) = True Then dteStartTime = CDate(![StartTime]) Debug.Print dteStartTime appt.Start = dteStartTime End If If IsDate(![EndTime]) = True Then dteEndTime = CDate(![EndTime]) Debug.Print dteEndTime appt.Start = dteEndTime End If appt.Location = Nz(![Location]) appt.Categories = Nz(![Category]) lngContactID = Nz(![ContactID]) strContactName = Nz(![ContactName]) Debug.Print "Contact name: " & strContactName
Appointments can have one or more contacts, which are stored in the Links collection of the AppointmentItem object. To add a contact to an appointment, first the contact is located in a Contacts folder (here the default local Contacts folder is searched), and then the ContactItem is added to the Links collection.
If lngContactID > 0 Then Set fldContacts = nms.GetDefaultFolder(olFolderContacts) On Error Resume Next Set con = fldContacts.Items.Find("[CustomerID] = " & lngContactID) If con Is Nothing Then strPrompt = "Can’t find Contact ID " & lngContactID & " in your default local Contacts folder" Debug.Print strPrompt Else Set lnks = appt.Links lnks.Add con End If On Error GoTo ErrorHandler End If appt.Close (olSave)
Go the next record.
NextItemAppt: .MoveNext Loop .Close End With
When all the selected records have been processed, put up an informative message box.
strTitle = "Done" If blnSomeSkipped = True Then strPrompt = "All appointments created; some records skipped " & "because of missing information." & vbCrLf & "See " & strDocsPath & "Skipped Records.txt for details." Else strPrompt = "All appointments created in " & pstrFolderName & " folder" End If MsgBox strPrompt, vbOKOnly + vbInformation, strTitle
Other cases are handled similarly.
Case "Contact" blnSomeSkipped = False With rstData Do While Not .EOF ‘Get Contact ID for reference lngContactID = Nz(![ContactID]) Debug.Print "Contact ID: " & lngContactID ‘Check for required name information strTest = Nz(![ContactName]) Debug.Print "Contact name: " & strTest If strTest = "" Then blnSomeSkipped = True Print #1, Print #1, "No name for Contact " & lngContactID GoTo NextItemContact End If strFullName = Nz(![FirstNameFirst]) strJobTitle = Nz(![JobTitle]) strStreetAddress = Nz(![StreetAddress]) strCity = Nz(![City]) strStateProv = Nz(![StateProv]) strPostalCode = Nz(![PostalCode]) strCountry = Nz(![Country]) strCompanyName = Nz(![CompanyName]) strSalutation = Nz(![Salutation]) strEMailRecipient = Nz(![EmailName]) ‘Create new contact item in selected folder Set con = pfld.Items.Add With con .CustomerID = lngContactID .FullName = strFullName .JobTitle = strJobTitle .BusinessAddressStreet = strStreetAddress .BusinessAddressCity = strCity .BusinessAddressState = strStateProv .BusinessAddressPostalCode = strPostalCode .BusinessAddressCountry = strCountry .CompanyName = strCompanyName .NickName = strSalutation .Email1Address = strEMailRecipient .Close (olSave) End With NextItemContact: .MoveNext Loop .Close End With strTitle = "Done" If blnSomeSkipped = True Then strPrompt = "All contacts created; some records skipped because " & "of missing information." & vbCrLf & "See " & strDocsPath & "Skipped Records.txt for details." Else strPrompt = "All contacts created in " & pstrFolderName & " folder" End If MsgBox strPrompt, vbOKOnly + vbInformation, strTitle Case "Mail message" blnSomeSkipped = False With rstData Do While Not .EOF ‘Get Contact ID for reference lngContactID = Nz(![ContactID]) Debug.Print "Contact ID: " & lngContactID ‘Check for required email information strTest = Nz(![EmailName]) Debug.Print "Email address: " & strTest If strTest = "" Then blnSomeSkipped = True Print #1, Print #1, "No email address for Contact " & lngContactID GoTo NextItemMail End If strEMailRecipient = Nz(![EmailName]) dteLastMeeting = Nz(![LastMeetingDate]) strMessage = Nz(Me![MessageText]) If strMessage <> "" Then strBody = strMessage Else strBody = "Your last meeting was on " & dteLastMeeting & "; please call to arrange a meeting by the end of the year." End If ‘Create new mail message Set msg = pfld.Items.Add With msg .To = strEMailRecipient .Subject = "Reminder" .Body = strBody .Send End With NextItemMail: .MoveNext Loop .Close End With strTitle = "Done" If blnSomeSkipped = True Then strPrompt = "All mail messages created; some records skipped " & " because of missing information." & vbCrLf & "See " & strDocsPath & "Skipped Records.txt for details." Else strPrompt = "All mail messages created in " & pstrFolderName End If MsgBox strPrompt, vbOKOnly + vbInformation, strTitle Case "Task" blnSomeSkipped = False With rstData Do While Not .EOF ‘Check for required task information strTest = Nz(![TaskName]) Debug.Print "Task: " & strTest If strTest = "" Then blnSomeSkipped = True Print #1, Print #1, "No task name" GoTo NextItemTask End If strTaskName = Nz(![TaskName]) lngContactID = Nz(![ContactID]) dteStartDate = Nz(![StartDate]) dteDueDate = Nz(![DueDate]) strStatus = Nz(![Status])
Convert the Status text from the Access table into a Long value for writing to the Outlook record.
lngStatus = Switch(strStatus = "Not started", 0, strStatus = "In progress", 1, strStatus = "Completed", 2, "", 0) ‘Create new task item in selected Tasks folder Set tsk = pfld.Items.Add tsk.Subject = strTaskName tsk.StartDate = dteStartDate tsk.DueDate = dteDueDate tsk.Status = lngStatus
Tasks can have one or more contacts, which are stored in the Links collection of the TaskItem object. To add a contact to a task, first the contact is located in a Contacts folder (here the default local Contacts folder is searched) and then the ContactItem is added to the Links collection.
lngContactID = Nz(![ContactID]) strContactName = Nz(![ContactName]) Debug.Print "Contact name: " & strContactName ‘Add contact to item, using the Links collection If lngContactID > 0 Then ‘There is a contact for this appointment; attempt to ‘locate this contact in the default Contacts folder. Set fldContacts = nms.GetDefaultFolder(olFolderContacts) On Error Resume Next Set con = fldContacts.Items.Find("[CustomerID] = " & lngContactID) If con Is Nothing Then strPrompt = "Can’t find Contact ID " & lngContactID & " in your default local Contacts folder" Debug.Print strPrompt Else Set lnks = tsk.Links lnks.Add con End If End If tsk.Close (olSave) NextItemTask: .MoveNext Loop .Close End With strTitle = "Done" If blnSomeSkipped = True Then strPrompt = "All tasks created; some records skipped because " & "of missing information." & vbCrLf & "See " & strDocsPath & "Skipped Records.txt for details." Else strPrompt = "All tasks created in " & pstrFolderName & " folder" End If MsgBox strPrompt, vbOKOnly + vbInformation, strTitle End Select ErrorHandlerExit: Close #1 Exit Sub ErrorHandler: If Err = 429 Then ‘Outlook is not running; open Outlook with CreateObject. Set appOutlook = CreateObject("Outlook.Application") Resume Next Else MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End If End Sub
Email a Report Form
The final form illustrating exporting Access data to Outlook shows you how to output an Access report to one of a variety of formats and then email the exported report. The EMail Access Report form is shown in Figure 12.15.
Figure 12.15
It is a simple form, with three comboboxes for selecting the report, recipient, and format, and a command button to save the report to the selected format and email it to the recipient. The cboSelectReport combobox has tlkpReports as its row source, a lookup table that lists report names and their record sources. cboSelectRecipient uses qryContacts as its row source with contact names and email addresses. cboSelectFormat has tlkpFormats as its row source, listing the available formats and their extensions (for use in code.
The available formats have their advantages and disadvantages, which are listed in the following table.
| Format Type | Advantages | Disadvantages |
|---|---|---|
| Access Snapshot | Excellent appearance; not editable. | Users who don’t have Access have to install the Snapshot Viewer to view it. |
| Adobe PDF | Excellent appearance; not editable. Almost everybody has the Adobe Viewer, or can easily download and install it. | You have to purchase Adobe Acrobat to generate these files (or use a third-party utility that doesn’t work as well, and is probably illegal). |
| Comma-Delimited Text File | Widely supported format; excellent for importing into other databases. | Doesn’t look like the report. |
| Excel Worksheet | Many users have Excel; a good choice if the data needs to be manipulated. | Doesn’t look like the report. |
| Plain Text | The lowest common denominator format; anyone who has even Notepad can view this format. | Doesn’t look like the report. |
| Rich Text | Looks somewhat like the report, though there are some appearance problems. | Need Word to view it. |
The code on the cmdEMailReport command button’s Click event calls one of a group of Sub procedures, depending on the chosen format. This procedure is listed below, with commentary.
Private Sub cmdEMailReport_Click() On Error GoTo ErrorHandler Dim strFormatType As String
Pick up format type from combobox.
strFormatType = Me![cboSelectFormat].Column(0) Debug.Print "Selected format: " & strFormatType
Set up Select Case statement to process each format type separately by calling a Sub procedure.
Select Case strFormatType Case "Access Snapshot" Call SendReportSNP(Me) Case "Adobe PDF" Call SendReportPDF(Me) Case "Rich Text" Call SendReportRTF(Me) Case "Comma-Delimited Text File" Call SendReportCSV(Me) Case "Plain Text" Call SendReportTXT(Me) Case "Excel Worksheet" Call SendReportWKS(Me) End Select ErrorHandlerExit: Exit Sub ErrorHandler: MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End Sub
The procedures for the different formats (located in the basOutlookAutomation module) follow, with commentary (full commentary only for the first procedure).
Sub SendReportSNP(frm As Access.Form) On Error GoTo ErrorHandler
Set variables for the report name, data source, display name, email address, Contact ID, output file name, and extension, file path, and concatenated file name and path.
strReport = Nz(frm![cboSelectReport].Column(0)) strDataSource = Nz(frm![cboSelectReport].Column(2)) strDisplayName = Nz(frm![cboSelectReport].Column(1)) strEMailRecipient = Nz(frm![cboSelectRecipient].Column(0)) lngContactID = frm![cboSelectRecipient].Column(2) strFileName = Mid(Nz(frm![cboSelectReport].Column(0)), 4) strExtension = Nz(frm![cboSelectFormat].Column(1)) strFilePath = GetDocsDir() strFileAndPath = strFilePath & strFileName & strExtension Debug.Print "File name and path: " & strFileAndPath
Initialize the progress bar (using an arbitrary division of four units).
varReturn = SysCmd(acSysCmdInitMeter, "Creating output file ...", 4)
Update the progress bar.
varReturn = SysCmd(acSysCmdUpdateMeter, 1) Use the FileSystemObject to test whether there is an old file, and delete it if there is one.
Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(strFileAndPath) = True Then fso.DeleteFile strFileAndPath End If ‘Update the progress bar varReturn = SysCmd(acSysCmdUpdateMeter, 2)
Create the new snapshot file in the Documents\Access Merge folder, using the OutputTo method.
DoCmd.OutputTo objecttype:=acOutputReport, objectname:=strReport, outputformat:=acFormatSNP, outputfile:=strFileAndPath, autostart:=False ‘Update the progress bar varReturn = SysCmd(acSysCmdUpdateMeter, 3)
Test for the existence of the specified report file, using the FileSystemObject, with a loop to prevent premature cancellation.
TryAgain: Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(strFileAndPath) = False Then GoTo TryAgain End If ‘Update the progress bar varReturn = SysCmd(acSysCmdUpdateMeter, 4)
Create the new mail message and attach the snapshot file to it.
Set appOutlook = GetObject(, Outlook.Application) Set itm = appOutlook.CreateItem(olMailItem) With itm .To = strEMailRecipient .Subject = strDisplayName & " report" .Body = "This file was exported from " & strReport & " on " & Format(Date, "m/d/yyyy") & "." & vbCrLf & vbCrLf & "You need the Access Snapshot Viewer to view this file." & vbCrLf & vbCrLf .Attachments.Add strFileAndPath .Display End With ErrorHandlerExit: ‘Remove the progress bar varReturn = SysCmd(acSysCmdRemoveMeter) Exit Sub ErrorHandler: If Err = 429 Then ‘Outlook is not running; open Outlook with CreateObject. Set appOutlook = CreateObject("Outlook.Application") Resume Next Else MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End If End Sub Sub SendReportRTF(frm As Access.Form) On Error GoTo ErrorHandler strReport = Nz(frm![cboSelectReport].Column(0)) strDataSource = Nz(frm![cboSelectReport].Column(2)) strDisplayName = Nz(frm![cboSelectReport].Column(1)) strEMailRecipient = Nz(frm![cboSelectRecipient].Column(0)) lngContactID = frm![cboSelectRecipient].Column(2) strFileName = Mid(Nz(frm![cboSelectReport].Column(0)), 4) strExtension = Nz(frm![cboSelectFormat].Column(1)) strFilePath = GetDocsDir() strFileAndPath = strFilePath & strFileName & strExtension Debug.Print "File name and path: " & strFileAndPath ‘Initialize the progress bar (using an arbitrary division of four units). varReturn = SysCmd(acSysCmdInitMeter, "Creating output file ...", 4) ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 1) ‘Delete old file, if there is one Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(strFileAndPath) = True Then fso.DeleteFile strFileAndPath End If ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 2) ‘Create new rich text file in Documents\Access Merge folder DoCmd.OutputTo objecttype:=acOutputReport, objectname:=strReport, outputformat:=acFormatRTF, outputfile:=strFileAndPath, autostart:=False ‘Test for existence of specified report file, with loop ‘to prevent premature cancellation TryAgain: Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(strFileAndPath) = False Then GoTo TryAgain End If ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 3) ‘Create new mail message and attach rich text file to it Set appOutlook = GetObject(, Outlook.Application) Set itm = appOutlook.CreateItem(olMailItem) With itm .To = strEMailRecipient .Subject = strDisplayName & " report" .Body = "This file was exported from " & strReport & " on " & Format(Date, "m/d/yyyy") & "." & vbCrLf & vbCrLf & "You need Word to view this file." & vbCrLf & vbCrLf .Attachments.Add strFileAndPath .Display End With ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 4) ErrorHandlerExit: ‘Remove the progress bar. varReturn = SysCmd(acSysCmdRemoveMeter) Exit Sub ErrorHandler: If Err = 429 Then ‘Outlook is not running; open Outlook with CreateObject. Set appOutlook = CreateObject("Outlook.Application") Resume Next Else MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End If End Sub Sub SendReportTXT(frm As Access.Form) On Error GoTo ErrorHandler strReport = Nz(frm![cboSelectReport].Column(0)) strDataSource = Nz(frm![cboSelectReport].Column(2)) strDisplayName = Nz(frm![cboSelectReport].Column(1)) strEMailRecipient = Nz(frm![cboSelectRecipient].Column(0)) lngContactID = frm![cboSelectRecipient].Column(2) strFileName = Mid(Nz(frm![cboSelectReport].Column(0)), 4) strExtension = Nz(frm![cboSelectFormat].Column(1)) strFilePath = GetDocsDir() strFileAndPath = strFilePath & strFileName & strExtension Debug.Print "File name and path: " & strFileAndPath ‘Initialize the progress bar (using an arbitrary division of four units). varReturn = SysCmd(acSysCmdInitMeter, "Creating output file ...", 4) ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 1) ‘Delete old file, if there is one Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(strFileAndPath) = True Then fso.DeleteFile strFileAndPath End If ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 2) ‘Create new rich text file in Documents\Access Merge folder DoCmd.OutputTo objecttype:=acOutputReport, objectname:=strReport, outputformat:=acFormatTXT, outputfile:=strFileAndPath, autostart:=False ‘Test for existence of specified report file, with loop ‘to prevent premature cancellation TryAgain: Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(strFileAndPath) = False Then GoTo TryAgain End If ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 3) ‘Create new mail message and attach text file to it Set appOutlook = GetObject(, Outlook.Application) Set itm = appOutlook.CreateItem(olMailItem) With itm .To = strEMailRecipient .Subject = strDisplayName & " report" .Body = "This file was exported from " & strReport & " on " & Format(Date, "m/d/yyyy") & "." & vbCrLf & vbCrLf .Attachments.Add strFileAndPath .Display End With ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 4) ErrorHandlerExit: ‘Remove the progress bar varReturn = SysCmd(acSysCmdRemoveMeter) Exit Sub ErrorHandler: If Err = 429 Then ‘Outlook is not running; open Outlook with CreateObject. Set appOutlook = CreateObject("Outlook.Application") Resume Next Else MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End If End Sub Sub SendReportWKS(frm As Access.Form) On Error GoTo ErrorHandler strReport = Nz(frm![cboSelectReport].Column(0)) strDataSource = Nz(frm![cboSelectReport].Column(2)) strDisplayName = Nz(frm![cboSelectReport].Column(1)) strEMailRecipient = Nz(frm![cboSelectRecipient].Column(0)) lngContactID = frm![cboSelectRecipient].Column(2) strFileName = Mid(Nz(frm![cboSelectReport].Column(0)), 4) strExtension = Nz(frm![cboSelectFormat].Column(1)) strFilePath = GetDocsDir() strFileAndPath = strFilePath & strFileName & strExtension Debug.Print "File name and path: " & strFileAndPath ‘Initialize the progress bar (using an arbitrary division of four units). varReturn = SysCmd(acSysCmdInitMeter, "Creating output file ...", 4) ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 1) ‘Delete old file, if there is one Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(strFileAndPath) = True Then fso.DeleteFile strFileAndPath End If ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 2) ‘Create new worksheet file in Documents\Access Merge folder DoCmd.OutputTo objecttype:=acOutputReport, objectname:=strReport, outputformat:=acFormatXLS, outputfile:=strFileAndPath, autostart:=False ‘Test for existence of specified report file, with loop ‘to prevent premature cancellation TryAgain: Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(strFileAndPath) = False Then GoTo TryAgain End If ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 3) ‘Create new mail message and attach worksheet file to it Set appOutlook = GetObject(, Outlook.Application) Set itm = appOutlook.CreateItem(olMailItem) With itm .To = strEMailRecipient .Subject = strDisplayName & " report" .Body = "This file was exported from " & strReport & " on " & Format(Date, "m/d/yyyy") & "." & vbCrLf & vbCrLf & "You need Excel to view this file." & vbCrLf & vbCrLf .Attachments.Add strFileAndPath .Display End With ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 4) ErrorHandlerExit: ‘Remove the progress bar varReturn = SysCmd(acSysCmdRemoveMeter) Exit Sub ErrorHandler: If Err = 429 Then ‘Outlook is not running; open Outlook with CreateObject. Set appOutlook = CreateObject("Outlook.Application") Resume Next Else MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End If End Sub Sub SendReportCSV(frm As Access.Form) On Error GoTo ErrorHandler strReport = Nz(frm![cboSelectReport].Column(0)) strDataSource = Nz(frm![cboSelectReport].Column(2)) strSpec = Mid(strDataSource, 4) & " Export Specification" strDisplayName = Nz(frm![cboSelectReport].Column(1)) strEMailRecipient = Nz(frm![cboSelectRecipient].Column(0)) lngContactID = frm![cboSelectRecipient].Column(2) strFileName = Mid(Nz(frm![cboSelectReport].Column(0)), 4) strExtension = Nz(frm![cboSelectFormat].Column(1)) strFilePath = GetDocsDir() strFileAndPath = strFilePath & strFileName & strExtension Debug.Print "File name and path: " & strFileAndPath ‘Initialize the progress bar (using an arbitrary division of 5 units). varReturn = SysCmd(acSysCmdInitMeter, "Creating output file ...", 5) ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 1) ‘Delete old file, if there is one Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(strFileAndPath) = True Then fso.DeleteFile strFileAndPath End If ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 2)
Create a new comma-delimited text file in the Documents\Access Merge folder, using the TransferText method.
DoCmd.TransferText transfertype:=acExportDelim, specificationname:=strSpec, TableName:=strDataSource, FileName:=strFileAndPath, HasFieldNames:=True ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 3) ‘Test for existence of specified report file, with loop ‘to prevent premature cancellation TryAgain: Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(strFileAndPath) = False Then GoTo TryAgain End If ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 4) ‘Create new mail message and attach comma-delimited text file to it Set appOutlook = GetObject(, Outlook.Application) Set itm = appOutlook.CreateItem(olMailItem) With itm .To = strEMailRecipient .Subject = strDisplayName & " report" .Body = "This file was exported from " & strDataSource & " on " & Format(Date, "m/d/yyyy") & "." & vbCrLf & vbCrLf .Attachments.Add strFileAndPath .Display End With ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 5) ErrorHandlerExit: ‘Remove the progress bar. varReturn = SysCmd(acSysCmdRemoveMeter) Exit Sub ErrorHandler: If Err = 429 Then ‘Outlook is not running; open Outlook with CreateObject. Set appOutlook = CreateObject("Outlook.Application") Resume Next Else MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End If End Sub Sub SendReportPDF(frm As Access.Form)
This code assumes that you have installed Adobe Acrobat and have assigned the PDF printer to a copy of each report, with “PDF” appended to its name.
On Error GoTo ErrorHandler strReport = Nz(frm![cboSelectReport].Column(0)) & "PDF" strDataSource = Nz(frm![cboSelectReport].Column(2)) strDisplayName = Nz(frm![cboSelectReport].Column(1)) strEMailRecipient = Nz(frm![cboSelectRecipient].Column(0)) lngContactID = frm![cboSelectRecipient].Column(2) strFileName = Nz(frm![cboSelectReport].Column(1)) strExtension = Nz(frm![cboSelectFormat].Column(1)) strFilePath = GetDocsDir() strFileAndPath = strFilePath & strFileName & strExtension Debug.Print "File name and path: " & strFileAndPath ‘Initialize the progress bar (using an arbitrary division of 3 units) varReturn = SysCmd(acSysCmdInitMeter, "Creating output file ...", 4) ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 1)
Create the PDF file by printing the report to the PDF printer, previously selected for this report.
DoCmd.OpenReport strReport, acViewNormal varReturn = SysCmd(acSysCmdUpdateMeter, 2) ‘Test for existence of specified report file, with loop ‘to prevent premature cancellation TryAgain: Set fso = CreateObject("Scripting.FileSystemObject") If fso.FileExists(strFileAndPath) = False Then GoTo TryAgain End If ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 3) ‘Create new mail message and attach PDF file to it Set appOutlook = GetObject(, Outlook.Application) Set itm = appOutlook.CreateItem(olMailItem) With itm .To = strEMailRecipient .Subject = strDisplayName & " report" .Body = "This file was exported from " & strReport & " on " & Format(Date, "m/d/yyyy") & "." & vbCrLf & vbCrLf & "You need the Adobe Acrobat Viewer to open this file." & vbCrLf & vbCrLf .Attachments.Add strFileAndPath .Display End With ‘Update the progress bar. varReturn = SysCmd(acSysCmdUpdateMeter, 4) ErrorHandlerExit: ‘Remove the progress bar varReturn = SysCmd(acSysCmdRemoveMeter) Exit Sub ErrorHandler: If Err = 429 Then ‘Outlook is not running; open Outlook with CreateObject. Set appOutlook = CreateObject("Outlook.Application") Resume Next Else MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End If End Sub
Figure 12.16 shows the EBooks by Category report exported to Adobe PDF format.
Figure 12.16
EAN: 2147483647
Pages: 124