Importing Data from Outlook Items to Access

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