Create appointment to custom (shared) outlook calendar

Hi,

I'm using access 2003

I'm looking for some code to create appointments into a shared outlook
calendar.

We've got several shared calendars and I need to post appointments into a
specific one using dates and times from our access database.

I've got the following code, but this puts the appointments in my personal
calendar;

I can't figure out how to modify this code to make it work for me,

Anyone any ideas?

Cheers,

Paul

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!ApptStartDate & " " & Me!ApptTime
..Duration = Me!ApptLength
..AllDayEvent = True
..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

You should repost this in the program_vba group on this server.

--
Diane Poremsky [MVP - Outlook]
Outlook Tips: http://www.outlook-tips.net/
Outlook & Exchange Solutions Center: http://www.slipstick.com/

Outlook Tips by email:


EMO - a weekly newsletter about Outlook and Exchange:


How many email accounts are in your main Outlook profile?
http://forums.slipstick.com/showthread.php?t=36602

"Paul" wrote in message
...
Hi,

I'm using access 2003

I'm looking for some code to create appointments into a shared outlook
calendar.

We've got several shared calendars and I need to post appointments into a
specific one using dates and times from our access database.

I've got the following code, but this puts the appointments in my personal
calendar;

I can't figure out how to modify this code to make it work for me,

Anyone any ideas?

Cheers,

Paul

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!ApptStartDate & " " & Me!ApptTime
.Duration = Me!ApptLength
.AllDayEvent = True
.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