Automated appointments from Access to Shared Calendars



Hi. I would like to send appointments from Acess to the shared Outlook
calendars of my sales staff. I have created the underlying table
"tblAppointment" and a form for entering the data, "frmAppointments and have
copied the following code in to create the appointment in Outlook. Obviously,
it only creates the appointment in my Calendar.

Could you please modify the following code to send the appointment to a
designated salespersons calendar. Your help is greatly appreciated:)

Private Sub cmdAddAppt_Click()
On Error GoTo Add_Err
'Save record first to be sure required fields are filled.
DoCmd.RunCommand acCmdSaveRecord
'Exit the procedure if appointment has been added to Outlook.
If Me!AddedToOutlook = True Then
MsgBox "This appointment is already added to Microsoft Outlook"
Exit Sub
'Add a new appointment.
Dim objOutlook As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Dim objRecurPattern As Outlook.RecurrencePattern
Set objOutlook = CreateObject("Outlook.Application")
Set objAppt = objOutlook.CreateItem(olAppointmentItem)
With objAppt
.Start = Me!ApptDate & " " & Me!ApptTime
.Duration = Me!ApptLength
.Subject = Me!Appt
If Not IsNull(Me!ApptNotes) Then .Body = Me!ApptNotes
If Not IsNull(Me!ApptLocation) Then .Location = Me!ApptLocation
If Me!ApptReminder Then
.ReminderMinutesBeforeStart = Me!ReminderMinutes
.ReminderSet = True
End If
Set objRecurPattern = .GetRecurrencePattern

With objRecurPattern
.RecurrenceType = olRecursWeekly
.Interval = 1
'Once per week
'You can hard-wire in these dates or get the
'information from text boxes, as used here.
'.PatternStartDate = #12/1/2003#
.PatternStartDate = Me!ApptStartDate
'.PatternEndDate = #12/30/2003#
.PatternEndDate = Me!ApptEndDate
End With
.Close (olSave)
End With
'Release the AppointmentItem object variable.
Set objAppt = Nothing
End If
'Release the object variables.
Set objOutlook = Nothing
.....Set objRecurPattern = Nothing
'Set the AddedToOutlook flag, save the record, display
'a message.
Me!AddedToOutlook = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit Sub
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub

End Sub


This line will create an appointment in your default local Calendar.

Set objAppt = objOutlook.CreateItem(olAppointmentItem)

You need to change it to put the appointment into the shared calendar
of your chosen recipient like this:

Set objAppt = CreateSharedDefaultAppointment("Smith, John")

Where "Smith, John" is the resolveable name of the recipient. Here is
the function that creates the appointment. Since you've declared other
objects early-bound, I left early bound references in my function:

Function CreateSharedDefaultAppointment(recip As Variant) As

Dim olNS As Outlook.NameSpace
Dim fldr As Outlook.MAPIFolder
Dim tempRecip As Outlook.recipient

Select Case TypeName(recip)
Case "Recipient"
' Recipient object already created
Set fldr = olNS.GetSharedDefaultFolder(recip, olFolderCalendar)

Case "String"
' create Recipient object
Set olNS = GetNS(GetOutlookApp)
Set tempRecip = olNS.CreateRecipient(recip)

Set fldr = olNS.GetSharedDefaultFolder(tempRecip,

End Select

Set CreateSharedDefaultAppointment =

End Function


Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question