Outlook Appointment from Access

[rtdc]

I have been asked if I can place an appointment reminder in a specific calendar within outlook, I have been placing appointments in outlook for years using code like this

Dim objOutlook As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Dim objRecurPattern As Outlook.RecurrencePattern
Dim dayz As Long, N As String, SID As String
N = Forms![OutlookReminder_frm]![Name_Field]
SID = Forms![OutlookReminder_frm]![StudentID]
Dim total As Long
Set objOutlook = CreateObject("Outlook.Application")
Set objAppt = objOutlook.CreateItem(olAppointmentItem)
With objAppt
.Start = Forms![OutlookReminder_frm]![TxtDate] & " " & Forms![OutlookReminder_frm]![TxtTime] 'change this to Date and time - mine is from a combo boxes
.Subject = SID & " " & N & " " & Forms![OutlookReminder_frm]![TxtSubject]
.Duration = Forms![OutlookReminder_frm]![TxtDuration]
.ReminderSet = True
.ReminderMinutesBeforeStart = Forms![OutlookReminder_frm]![TxtReminder]
.Body = Nz(Forms![OutlookReminder_frm]![TxtBody], " ")
.Importance = olImportanceHigh
.Save
.Close (olSave)
End With
'Release the AppointmentItem object variable.
Set objAppt = Nothing


'Release the Outlook object variable.
Set objOutlook = Nothing

It seems this code just puts it in the default calendar but the user has two calendars one local and one shared and it is the sheared one that need populating. They have tried making the shared calendar the default and it still puts it in the other local calendar.

Did a bit of googling but can come up with an answer any suggestions?

Cheers

 

[darbid]

Maybe this might help. I use this for delegates which is I think the same. IT tests if the person has delegate rights.

Dim objNS As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder 'get name of other persons folder
Dim objRecip As Outlook.Recipient 'other persons name
Dim strName As String 'the name or email of the persons folder

On Error Resume Next

' ### name EMAIL IS BETTER of person whose Calendar you want to use ###
strName = "email here"

'objApp is the outlook application

Set objNS = objApp.GetNamespace("MAPI")

Set objRecip = objNS.CreateRecipient(strName)

objRecip.Resolve

If Not objRecip.Resolve Then
    CheckForDelegate = False
End If


Set objFolder = objNS.GetSharedDefaultFolder(objRecip, olFolderCalendar)

If objFolder Is Nothing Then
    CheckForDelegate = False
Else
    CheckForDelegate = True
End If

Set objNS = Nothing
Set objFolder = Nothing
Set objRecip = Nothing

Set objApp = Nothing

once you have the folder then

Set objAppt = objFolder.Items.Add