Expert One-on-One Microsoft Access Application Development

In addition to exporting Access data to Outlook items, you can also import data from Outlook items into Access tables. For the most common case of importing Outlook contacts to Access, I have written an add-in to do the importing (the Outlook Automation add-in, available from the Code Samples page of my Web site, www.helenfeddema.com). My add-in is complex, because it handles custom properties as well as built-in properties, but for importing data from standard items in the default local folder, much simpler VBA code will do. The Import from Outlook form has a Tab control with two pages, one for importing data from a single currently open Outlook item, and the other for importing from multiple selected Outlook items. This form is shown in its initial state in Figure 12.17.

Figure 12.17

To import data from the current Outlook item, I use the Inspector object, an oddly named object in the Outlook object model that represents whatever item (if any) is currently open. The cmdImportDatafromOutlookItem_Click event procedure follows, with commentary.

Private Sub cmdImportDatafromOutlookItem_Click() On Error GoTo ErrorHandler Set appOutlook = GetObject(, Outlook.Application)

Set an Inspector variable to the ActiveInspector property of the Outlook Application object, which represents the currently open item. If no item is open, a case in the error handler exits the procedure.

Set ins = appOutlook.ActiveInspector

Set a variable representing the item type of the Inspector, picked up from its Class property.

lngItemType = Nz(ins.CurrentItem.Class) Debug.Print "Item type: " & lngItemType

Exit if no usable item has been selected (a second check in case there is a strange item open with no class).

If lngItemType = 0 Then strPrompt = "No Outlook item open; exiting" MsgBox strPrompt, vbOKOnly, "No item open" GoTo ErrorHandlerExit End If Set dbs = CurrentDb Set subTable = Me![subTableSingle]

Set up a Select Case statement to process each item type correctly.

Select Case lngItemType Case olAppointment strTable = "tblAppointmentsFromOutlook"

Clear old data from the table, using a SQL statement delete query.

strSQL = "DELETE * FROM " & strTable DoCmd.SetWarnings False DoCmd.RunSQL strSQL

Set up a recordset based on the appropriate table for import.

Set rst = dbs.OpenRecordset(strTable, dbOpenDynaset) With rst Set appt = ins.CurrentItem

Add a record to the table, and copy values from the Outlook item to its fields.

.AddNew ![Subject] = appt.Subject ![Location] = appt.Location ![StartTime] = appt.Start ![EndTime] = appt.End ![Category] = appt.Categories .Update appt.Close (olSave) End With

Assign the appropriate source object to the subTable subform.

subTable.SourceObject = "fsubAppointmentsFromOutlook" Case olContact strTable = "tblContactsFromOutlook" ‘Clear old data from table strSQL = "DELETE * FROM " & strTable DoCmd.SetWarnings False DoCmd.RunSQL strSQL ‘Set up recordset based on table Set rst = dbs.OpenRecordset(strTable, dbOpenDynaset) With rst Set con = ins.CurrentItem .AddNew ![FirstName] = con.FirstName ![LastName] = con.LastName ![Salutation] = con.NickName ![StreetAddress] = con.BusinessAddressStreet ![City] = con.BusinessAddressCity ![StateOrProvince] = con.BusinessAddressState ![PostalCode] = con.BusinessAddressPostalCode ![Country] = con.BusinessAddressCountry ![CompanyName] = con.CompanyName ![JobTitle] = con.JobTitle ![WorkPhone] = con.BusinessTelephoneNumber ![MobilePhone] = con.MobileTelephoneNumber ![FaxNumber] = con.BusinessFaxNumber ![EmailName] = con.Email1Address .Update con.Close (olSave) End With subTable.SourceObject = "fsubContactsFromOutlook" Case olMail strTable = "tblMailMessagesFromOutlook" ‘Clear old data from table strSQL = "DELETE * FROM " & strTable DoCmd.SetWarnings False DoCmd.RunSQL strSQL ‘Set up recordset based on table Set rst = dbs.OpenRecordset(strTable, dbOpenDynaset) With rst Set msg = ins.CurrentItem Set msgReply = msg.Reply .AddNew ![Subject] = msg.Subject ![From] = msgReply.To ![To] = msg.To ![Sent] = msg.SentOn ![Message] = msg.Body .Update msg.Close (olSave) msgReply.Close (olDiscard) End With subTable.SourceObject = "fsubMailMessagesFromOutlook" Case olTask strTable = "tblTasksFromOutlook" ‘Clear old data from table strSQL = "DELETE * FROM " & strTable DoCmd.SetWarnings False DoCmd.RunSQL strSQL ‘Set up recordset based on table Set rst = dbs.OpenRecordset(strTable, dbOpenDynaset) With rst Set tsk = ins.CurrentItem .AddNew ![Subject] = tsk.Subject ![StartDate] = tsk.StartDate ![DueDate] = tsk.DueDate ![PercentComplete] = tsk.PercentComplete

Set up a Select Case statement to convert Outlook numeric status values to text for storage in the Access table.

lngStatus = tsk.Status Select Case lngStatus Case olTaskComplete strStatus = "Complete" Case olTaskDeferred strStatus = "Deferred" Case olTaskInProgress strStatus = "In progress" Case olTaskNotStarted strStatus = "Not started" Case olTaskWaiting strStatus = "Waiting" End Select ![Status] = strStatus .Update tsk.Close (olSave) End With subTable.SourceObject = "fsubTasksFromOutlook" Case Else MsgBox "Item type not supported for import; exiting" subTable.SourceObject = "" End Select ErrorHandlerExit: Exit Sub ErrorHandler: If Err = 429 Then ‘Outlook is not running; open Outlook with CreateObject. Set appOutlook = CreateObject("Outlook.Application") Resume Next ElseIf Err = 91 Then strPrompt = "No Outlook item open; exiting" MsgBox strPrompt, vbOKOnly, "No item open" GoTo ErrorHandlerExit Else MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description Resume ErrorHandlerExit End If End Sub

Figure 12.18 shows the form with data written to tblAppointmentsFromOutlook for an appointment item.

Figure 12.18

The other tab of the Import from Outlook form imports multiple items from Outlook, using the Outlook Selection object (introduced in Office 2000). This object represents the items selected in the current folder, allowing you to use an Outlook folder much like a MultiSelect listbox, selecting items for import into Outlook. Figure 12.19 shows an Outlook tasks folder with several tasks selected for import.

Figure 12.19

Clicking the cmdImportDataFromOutlook button on the Multiple Items page of the Import from Outlook form runs a procedure that is similar to the one on the Single Items page, except that it iterates through the Selection object (representing the items selected in the currently open folder) to process all the selected items. The procedure follows, with commentary on the Selection-related features.

Private Sub cmdImportDatafromOutlookItems_Click() On Error GoTo ErrorHandler Set appOutlook = GetObject(, Outlook.Application) Set nms = appOutlook.GetNamespace("MAPI")

Set up an Explorer variable to represent the current window displaying a folder in Outlook, and a MAPIFolder variable to represent the folder displayed in the Explorer.

Set exp = appOutlook.ActiveExplorer Set fld = exp.CurrentFolder Debug.Print "Folder default item type: " & fld.DefaultItemType

Store the folder item type to a variable for use later in the code.

lngItemType = fld.DefaultItemType Debug.Print "Folder item type: " & fld.DefaultItemType

Set up a Selection variable.

Set sel = exp.Selection

Count the number of selected items, and exit if none is selected.

lngSelectionCount = sel.Count Debug.Print "Number of selected contacts: " & lngSelectionCount ‘Exit if no contact has been selected. If lngSelectionCount = 0 Then MsgBox "No items selected; exiting" GoTo ErrorHandlerExit End If

Set up a DAO recordset based on the appropriate table for import.

Set dbs = CurrentDb Set subTable = Me![subTableMultiple]

Set up a Select Case statement to process items correctly for the folder type selected.

Select Case lngItemType Case olAppointmentItem strTable = "tblAppointmentsFromOutlook" ‘Clear old data from table strSQL = "DELETE * FROM " & strTable DoCmd.SetWarnings False DoCmd.RunSQL strSQL ‘Set up recordset based on table Set rst = dbs.OpenRecordset(strTable, dbOpenDynaset) With rst For Each itm In sel If itm.Class = olAppointment Then Set appt = itm .AddNew ![Subject] = appt.Subject ![Location] = appt.Location ![StartTime] = appt.Start ![EndTime] = appt.End ![Category] = appt.Categories .Update appt.Close (olSave) End If Next itm End With subTable.SourceObject = "fsubAppointmentsFromOutlook" Case olContactItem strTable = "tblContactsFromOutlook" ‘Clear old data from table strSQL = "DELETE * FROM " & strTable DoCmd.SetWarnings False DoCmd.RunSQL strSQL ‘Set up recordset based on table Set rst = dbs.OpenRecordset(strTable, dbOpenDynaset) With rst

Note that although the Selection object is a collection of items, it does not have an Items collection—you just iterate through it directly.

For Each itm In sel If itm.Class = olContact Then Set con = itm .AddNew ![FirstName] = con.FirstName ![LastName] = con.LastName ![Salutation] = con.NickName ![StreetAddress] = con.BusinessAddressStreet ![City] = con.BusinessAddressCity ![StateOrProvince] = con.BusinessAddressState ![PostalCode] = con.BusinessAddressPostalCode ![Country] = con.BusinessAddressCountry ![CompanyName] = con.CompanyName ![JobTitle] = con.JobTitle ![WorkPhone] = con.BusinessTelephoneNumber ![MobilePhone] = con.MobileTelephoneNumber ![FaxNumber] = con.BusinessFaxNumber ![EmailName] = con.Email1Address .Update con.Close (olSave) End If Next itm End With subTable.SourceObject = "fsubContactsFromOutlook" Case olMailItem strTable = "tblMailMessagesFromOutlook" ‘Clear old data from table strSQL = "DELETE * FROM " & strTable DoCmd.SetWarnings False DoCmd.RunSQL strSQL ‘Set up recordset based on table Set rst = dbs.OpenRecordset(strTable, dbOpenDynaset) With rst For Each itm In sel If itm.Class = olMail Then Set msg = itm Set msgReply = msg.Reply .AddNew ![Subject] = msg.Subject ![From] = msgReply.To ![To] = msg.To ![Sent] = msg.SentOn ![Message] = msg.Body .Update msg.Close (olSave) msgReply.Close (olDiscard) End If Next itm End With subTable.SourceObject = "fsubMailMessagesFromOutlook" Case olTaskItem strTable = "tblTasksFromOutlook" ‘Clear old data from table strSQL = "DELETE * FROM " & strTable DoCmd.SetWarnings False DoCmd.RunSQL strSQL ‘Set up recordset based on table Set rst = dbs.OpenRecordset(strTable, dbOpenDynaset) With rst For Each itm In sel If itm.Class = olTask Then Set tsk = itm .AddNew ![Subject] = tsk.Subject ![StartDate] = tsk.StartDate ![DueDate] = tsk.DueDate ![PercentComplete] = tsk.PercentComplete

Set up a Select Case statement to convert Outlook numeric status values to text for the Access table.

lngStatus = tsk.Status Select Case lngStatus Case olTaskComplete strStatus = "Complete" Case olTaskDeferred strStatus = "Deferred" Case olTaskInProgress strStatus = "In progress" Case olTaskNotStarted strStatus = "Not started" Case olTaskWaiting strStatus = "Waiting" End Select ![Status] = strStatus .Update tsk.Close (olSave) End If Next itm End With subTable.SourceObject = "fsubTasksFromOutlook" Case Else MsgBox "Folder type not supported for import; exiting" subTable.SourceObject = "" End Select ErrorHandlerExit: 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