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


On Mar 25, 8:20*pm, Skeletor <Skele...@discussions.microsoft.com>
wrote:
> 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