Working with Outlook Appointments

You may have calendar (appointment) data stored in an Access table, perhaps dating back to before Outlook became a part of Office. Because Outlook has a much richer interface for working with calendars than Access, I recommend exporting the Access calendar data to Outlook and working with it in Outlook calendars in the future.

To export data from an Access appointments table (such as the table from the sample Events database, called tblEvents) to Outlook appointments, use the function listed next (it can also be run from the mcrExportAppointments macro):

Public Function ExportAppointmentsToOutlook()

On Error GoTo ErrorHandler

Dim fldCalendar As Outlook.Folder

Dim appt As Outlook.Appointmentltem

Dim strApptName As String

Dim dteStartTime As Date

Dim dteEndTime As Date

Dim strStatus As String

Dim lngStatus As Long

Set appOutlook = GetObject(, "Outlook.Application")

Set nms = appOutlook.GetNamespace("MAPI")

Set fldCalendar = nms.GetDefaultFolder(olFolderCalendar)

Set dbs = CurrentDb

Set rst = dbs.OpenRecordset("tblEvents")

With rst

Do While Not .EOF

Check that there is an appointment subject.

Debug.Print "Appointment name: " & strApptName If strApptName = "" Then

GoTo NextAppt End If

Check for valid dates, and convert blank dates into 1/1/4501 (that is a blank date in Outlook).

If IsNull(![Start Time]) = True Then dteStartTime = #1/1/4501# Else dteStartTime = Nz(![Start Time]) End If

If IsNull(![End Time]) = True Then dteEndTime = #1/1/4501# Else dteEndTime = Nz(![End Time]) End If

Create a new appointment item in the local Calendar folder.

Set appt = fldCalendar.Items.Add appt.Subject = strApptName appt.Start = dteStartTime appt.End = dteEndTime appt.Location = Nz(![Location]) appt.Body = Nz(![Description]) appt.Close (olSave)

NextAppt:

.MoveNext Loop End With

MsgBox "Appointments exported to Outlook"

ErrorHandlerExit: Exit Function

ErrorHandler:

Outlook is not running; open Outlook with CreateObject.

If Err.Number = 429 Then

Set appOutlook = CreateObject("Outlook.Application") Resume Next Else

& "; Description: " & Err.Description Resume ErrorHandlerExit End If

End Function

Figure 8.21 shows the exported appointments in the Outlook calendar.

FIGURE 8.21

Appointments in the Outlook calendar exported from Access.

H Calendar

Q|0 Subject

¡Location | Start -

Id*

LzJ Recurrence: (none) (3 items)

g§j Dominion Bank - Closing

New Paltz Sun 7 23 '2006 3:00 PM

Sun 7 23/2006 4:00 PM

g§| Haircut - True Colors

Napanoch Tue 8/1/2006 2:00 PM

Tue 8/1/200(5 2:30 PM

H§ Office Conference

Online Hiu 8.10, 2006 10:00 AM

"Thu 8/10/2006 2:00 PM

To import appointments from your local Outlook calendar into an Access table (tblImportedCalendar), use the following function (it can also be run from the mcrImportCalendar macro):

Public Function ImportApptsFromOutlook()

On Error GoTo ErrorHandler

Dim fldCalendar As Outlook.Folder

Dim appt As Outlook.Appointmentltem

Dim strApptName As String

Dim dteStartTime As Date

Dim dteEndTime As Date

Dim strLocation As String

Dim strSQL As String

Dim strDescription As String

Set appOutlook = GetObject(, "Outlook.Application")

Set nms = appOutlook.GetNamespace("MAPI")

Set fldCalendar = nms.GetDefaultFolder(olFolderCalendar)

Clear table of old data.

strSQL = "DELETE * FROM tbllmportedCalendar" DoCmd.SetWarnings False DoCmd.RunSQL strSQL

Set dbs = CurrentDb

Set rst = dbs.OpenRecordset("tblImportedCalendar") Iterate through the appointments in the local Calendar folder and import them to the Access table.

For Each itm In fldCalendar.Items

If itm.Class = olAppointment Then Set appt = itm With appt strApptName = Nz(.Subject) dteStartTime = Nz(.Start) dteEndTime = Nz(.End) strLocation = Nz(.Location) strDescription = Nz(.Body) End With

With rst rst.AddNew

![Subject] = strApptName

If dteStartTime <> #1/1/4501# Then

![Start Time] = dteStartTime End If

![End Time] = dteEndTime End If

![Location] = strLocation ![Description] = strDescription .Update End With

End If Next itm rst.Close

DoCmd.OpenTable "tblImportedCalendar"

ErrorHandlerExit: Exit Function

ErrorHandler:

Outlook is not running; open Outlook with CreateObject.

If Err.Number = 429 Then

Set appOutlook = CreateObject("Outlook.Application") Resume Next Else

& "; Description: " & Err.Description Resume ErrorHandlerExit End If

End Function

Figure 8.22 shows the table of imported appointments, which is automatically opened at the end of the procedure.

FIGURE 8.22

A table of appointments imported from an Outlook calendar folder.

j^BSn^HMIMHMMHMmK«!

Subject

Start Time

End Time • Location -

Description

Dominion Bank - Closing

7/23/2006 3:00:00 PM

7/23/2006 4:00:00 PM New Paltz

Haircut - True Colors

8/1/2005 2:00:00 PM

8/1/2006 2:30:00 PM Napanoch

Office Conference

8/10/2006 10:00:00 AM

8/10/2006 2:00:00 PM Online

*

Record: H * |4 of 4

^Hsearch

For a more realistic scenario, in which you want to create appointments based on data in an Access table of project data, use the CreateProjectAppts function (it can also be run from the mcrCreateProjectAppts macro). This function selects records in tblContactsWithProjects that have a last meeting date older than a month ago, and creates an Outlook appointment for a project meeting for the following Monday for each of those records, writing data from several fields in the Access record to the appointment item:

Public Function CreateProjectAppts()

On Error GoTo ErrorHandler

Dim fldCalendar As Outlook.Folder Dim appt As Outlook.Appointmentltem Dim dteMonthAgo As Date Dim dteLastMeeting As Date Dim dteNextMonday As Date Dim strProject As String

Set appOutlook = GetObject(, "Outlook.Application") Set nms = appOutlook.GetNamespace("MAPI")

Set fldCalendar = nms.GetDefaultFolder(olFolderCalendar) Set dbs = CurrentDb

Set rst = dbs.OpenRecordset("tblContactsWithProjects") dteMonthAgo = DateAdd("m", -1, Date) dteNextMonday = NextMondayTime()

With rst

Do While Not .EOF

Check whether the last meeting date is older than a month ago.

dteLastMeeting = Nz(![LastMeetingDate]) strProject = Nz(![CurrentProject])

If dteLastMeeting < dteMonthAgo Then

Create a new appointment item in the local Calendar folder.

Set appt = fldCalendar.Items.Add appt.Subject = strProject appt.Start = dteNextMonday appt.Duration = "60" appt.ReminderSet = True appt.Body = "Monthly project meeting" appt.Close (olSave) End If .MoveNext Loop End With

MsgBox "Outlook project meeting appointments created "

ErrorHandlerExit: Exit Function

ErrorHandler:

Outlook is not running; open Outlook with CreateObject.

If Err.Number = 42 9 Then

Set appOutlook = CreateObject("Outlook.Application") Resume Next Else

& "; Description: " & Err.Description Resume ErrorHandlerExit End If

End Function

Figure 8.23 shows one of the appointments created by the procedure.

FIGURE 8.23

A project meeting appointment created from data in an Access table.

^^^ Appointment

Barn Renovation

Appointment

. B *

Format Text

Developer

©

| n /i j lJ] Calendar X Delete Close ^ Forward "

Appointment

Scheduling

■ ¡■Busy -i 115 minute

-nO Recurrence ¿J

-Jgy Categorize" £

Meeting Notes

Show

NJiHiBa

1 r 11.. t.- . l'I il '1". i-r M ..|i. .!!■- |i .

n your Calent

Jar,

II

1 Subject; gam Renovation

_M

1 Start time: | Mon 7/24/2006

T| 1 30:00 AM

_J7j ÖAII day event

1 End time: Mon 7. 24/20

06

T| j 11:00 AM

ZB

[Monthly project meeting

1

0 0

Post a comment