Automated appointments from Access to Shared Calendars

  • Thread starter Thread starter Skeletor
  • Start date Start date
S

Skeletor

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.
Else
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
.Save
.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
Add_Err:
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
Outlook.AppointmentItem

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,
olFolderCalendar)

End Select

Set CreateSharedDefaultAppointment =
fldr.Items.Add(olAppointmentItem)

End Function

--JP
 
Back
Top