Save Appointment in Outlook SHARED Folder

[rekabeilla]

Hi I am using the following code that i found online to add an appointment to Outlook Calendar and it works beautifully but it adds the appointment to my calendar and not our business' shared calendar. I have googled for an hour now and i can't get any code that i've found to save to the shared calendar to work. So i thought i'd post the code that works here and see if anybody can tell me how to tweak it to get it to save to the shared calendar?

' You are welcome to use this code if you leave all authorship information intact
'---------------------------------------------------------------------------------------
' Procedure : btnAddApptToOutlook_Click
' DateTime  : 7/09/2009
' Author    : Patrick Wood
' Purpose   : Add an Access Appointment Record to the Outlook Calendar
'---------------------------------------------------------------------------------------
'
Private Sub btnAddApptToOutlook_Click()
'On Error GoTo ErrHandle
 
    Dim olNS As Object
    Dim olApptFldr As Object
    
 
 
    ' Exit the procedure if appointment has been added to Outlook.
    If Me.chkAddedToOutlook = True Then
        MsgBox "This appointment has already added to Microsoft Outlook.", vbCritical
        Exit Sub
    Else
 
        ' Use late binding to avoid the "Reference" issue
        Dim olApp As Object        'Outlook.Application
        Dim olAppt As Object        'olAppointmentItem
 
        'This is how we would do it if we were using "early binding":
'        Dim olApp As Outlook.Application
'        Dim olappt As Outlook.AppointmentItem
'        Set olapp = CreateObject("Outlook.Application")
'        Set olappt = olapp.CreateItem(olAppointmentItem)
 
        If isAppThere("Outlook.Application") = False Then
            ' Outlook is not open, create a new instance
            Set olApp = CreateObject("Outlook.Application")
        Else
            ' Outlook is already open--use this method
            Set olApp = GetObject(, "Outlook.Application")
        End If

        Set olAppt = olApp.CreateItem(1) ' 1 = olAppointmentItem
 
        ' Add the Form data to the Appointment Properties
        With olAppt
            If Nz(Me.chkAllDayEvent) = True Then
                .Alldayevent = True
 
                ' Format the dates in the Form Controls
                Me.txtStartDate = FormatDateTime(Me.txtStartDate, vbShortDate)
                Me.txtEndDate = FormatDateTime(Me.txtEndDate, vbShortDate)
                ' For all day events use "" for the start time and the end time
                Me.cboStartTime = ""
                Me.cboEndTime = ""
 
                ' Get the Start and the End Dates
                Dim dteTempEnd As Date
                Dim dteStartDate As Date
                Dim dteEndDate As Date
                dteStartDate = CDate(FormatDateTime(Me.txtStartDate, vbShortDate)) ' Begining Date of appointment
                dteTempEnd = CDate(FormatDateTime(Me.txtEndDate, vbShortDate))      ' Use to compute End Date of appointment
 
                ' Add one day to dteEndDate so Outlook will set the number of days correctly
                dteEndDate = DateSerial(Year(dteTempEnd + 1), Month(dteTempEnd + 1), Day(dteTempEnd + 1))
 
                .start = dteStartDate
                .End = dteEndDate
 
                ' Set the number of minutes for each day in the AllDayEvent Appointment
                Dim lngMinutes As Long
 
                lngMinutes = CDate(Nz(dteEndDate)) - CDate(Nz(dteStartDate))
                ' The duration in Minutes, 1440 per day
                lngMinutes = lngMinutes * 1440
 
                ' Add the minutes to the Access Form
                Me.txtApptLength.Value = lngMinutes
 
                .Duration = lngMinutes
 
            Else
                ' The Validation Rule for the Start Date TextBox requires a
                ' Start Date so there is no need to check for it here
                If Len(Me.cboStartTime & vbNullString) = 0 Then
                    ' There is no end time on the Form
                    ' Add vbNullString ("") to avoid an error
                    Me.cboStartTime = vbNullString
                End If
 
                ' Set the Start Property Value
                .start = FormatDateTime(Me.txtStartDate, vbShortDate) _
                   & " " & FormatDateTime(Me.cboStartTime, vbShortTime)
 
                ' If there is no End Date on the Form just skip it
                If Len(Me.txtEndDate & vbNullString) > 0 Then
                    If Len(Me.cboEndTime & vbNullString) = 0 Then
                        ' There is no end time on the Form
                        ' Add vbNullString ("") to avoid an error
                        Me.cboEndTime = vbNullString
                    Else
                        ' Set the End Property Value
                        .End = FormatDateTime(Me.txtEndDate, vbShortDate) _
                           & " " & FormatDateTime(Me.cboEndTime, vbShortTime)
                    End If
                End If
 
                If Len(Me.txtApptLength & vbNullString) = 0 Then
                    Dim timStartTime As Date
                    Dim timEndTime As Date
 
                    ' Format the Start Time and End Time
                    timStartTime = FormatDateTime(Me.txtStartDate, vbShortDate) _
                           & " " & FormatDateTime(Me.cboStartTime, vbShortTime)
                    timEndTime = FormatDateTime(Me.txtEndDate, vbShortDate) _
                           & " " & FormatDateTime(Me.cboEndTime, vbShortTime)
 
                    .Duration = Me.txtApptLength
                End If
            End If
 
            If Nz(Me.chkAllDayEvent) = False Then
                .Alldayevent = False
            End If
 
            If Len(Me.cboApptDescription & vbNullString) > 0 Then
                .Subject = Me.cboApptDescription
            End If
 
            If Len(Me.txtApptNotes & vbNullString) > 0 Then
                .Body = Me.txtApptNotes
            End If
 
            If Len(Me.txtLocation & vbNullString) > 0 Then
                .Location = Me.txtLocation
            End If
 
            If Me.chkApptReminder = True Then
                If IsNull(Me.txtReminderMinutes) Then
                    Me.txtReminderMinutes.Value = 30
                End If
                .ReminderOverrideDefault = True
                .ReminderMinutesBeforeStart = Me.txtReminderMinutes
                .ReminderSet = True
            End If
 
            ' Save the Appointment Item Properties
            .Save
        End With
 
        ' Set chkAddedToOutlook to checked
        Me.chkAddedToOutlook = True
 
 
        ' Inform the user
        MsgBox "New Outlook Appointment Has Been Added!", vbInformation
    End If
 
ExitHere:
    ' Release Memory
    Set olApptFldr = Nothing
    Set olNS = Nothing
    Set olAppt = Nothing
    Set olApp = Nothing
    Exit Sub
 
ErrHandle:
    MsgBox "Error " & Err.Number & vbCrLf & Err.Description _
    & vbCrLf & "In procedure btnAddApptToOutlook_Click in Module Module1"
    Resume ExitHere
 
End Sub


'---------------------------------------------------------------------------------------
' Procedure : isAppThere
' Author    : Rick Dobson, Ph.D - Programming Microsoft Access 2000
' Purpose   : To check if an Application is Open
' Arguments : appName The name of the Application
' Example   : isAppThere("Outlook.Application")
'---------------------------------------------------------------------------------------
'
Function isAppThere(appName) As Boolean
On Error Resume Next
 
    Dim objApp As Object
 
    isAppThere = True
    Set objApp = GetObject(, appName)
    If Err.Number <> 0 Then isAppThere = False

Thank you!

 

[theDBguy]

Hi. Don't have an example for you but try searching for using a MAPI namespace in Outlook. Good luck!