Creating appointments from MS Access to Outlook

[FA]

Hi, I am using the following code in MS Access to genereate the
appointments in MS outlook. everytime when i click on create
appointment, it creates a new appointments in my personal calender in
outlook. Instead we have a shared calendter called "Assessments
Calander" and i want this function to create the appointment in that
calender instead of creating it in my personal calender.
Is it possible?????

Any help would be greatly appreciated.

Thanks


On Error GoTo Err_cmdCreateAppt_Click
Dim objOl As Outlook.Application
Dim objItem As Outlook.AppointmentItem
Dim blnOlRunning As Boolean
On Error Resume Next
blnOlRunning = True
Set objOl = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set objOl = CreateObject("Outlook.Application")
blnOlRunning = True
Err.Clear
End If

On Error GoTo 0

Set objItem = objOl.CreateItem(olAppointmentItem)

With objItem
.Start = CDate(Me.txtApptDate) + CDate(Me.txtApptTime)
.Duration = Me.txtDuration * Me.ogDuration
.Subject = Me.txtSubject & vbNullString
.Body = Me.txtBody & vbNullString

If Len(Me.txtReminder & vbNullString) > 0 Then
.ReminderSet = True
.ReminderMinutesBeforeStart = Me.txtReminder * Me.ogPeriod
Else
.ReminderMinutesBeforeStart = 0
.ReminderSet = False
End If

.Save
End With

If blnOlRunning = True Then
' display the new item
objItem.Display
Else
objOl.Quit
End If
Exit_cmdCreateAppt_Click:
Set objItem = Nothing
Set objOl = Nothing
Exit Sub
Err_cmdCreateAppt_Click:
Select Case Err

Case 0

Case Else
MsgBox Err.Description
Resume Exit_cmdCreateAppt_Click
End Select

 

[John Nurick]

I think you'll find the necessary information at www.outlookcode.com.