SharePoint Calendar in Outlook - how do I select it in Excel - VBA

I have a macro that will add/update outlook calendar items within excel but I need to know how to select the sharepiont calendar. It seems it can't find the object.

In Outlook the calendar is located under the "SharePoint Lists" Folder.

Thank you.

I used code from anther post on this site. (very helpfull)

Public Type aiAppointment
    dtmStart As Date
    booAllDayEvent As Boolean
    lngDuration As Long
    dtmRecurrenceEnds As Date
    lngReminderMinutesBeforeStart As Long
    'dtmEnd As Date
    strSubject As String
    strCategories As String
    strBody As String
    strLocation As String
    strEntryID As String
    strGlobalAppointmentID As String
    booDelete As Boolean
    strFolder As String
End Type
Function OutlookAppointment(appt As aiAppointment)
On Error GoTo AddAppt_Err
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem
Dim outRecurrPatt As Outlook.RecurrencePattern
Dim outNameSpace As Outlook.Namespace
Dim outFolder As Outlook.Folder
Dim strMSG As String
 
    Set outobj = CreateObject("outlook.application")
    Set outNameSpace = outobj.GetNamespace("MAPI")
    Set outFolder = outNameSpace.GetDefaultFolder(olFolderCalendar)
    If appt.strFolder <> "" Then
       Set outFolder = outFolder.Folders(appt.strFolder)
    End If
   
    If appt.strEntryID = "" Then
       Set outappt = outFolder.Items.Add
       
    Else
 
       ' This is OK for EntryID but cant find the equivalant for GlobalAppointmentID
       Set outappt = outNameSpace.GetItemFromID(appt.strEntryID, outFolder.StoreID)
       'If outappt.GlobalAppointmentID <> Me.txtGlobalAppointmentID Then
       '   MsgBox "The GlobalAppointmentID does not match"
       'Else
    End If
       
    With outappt
         If appt.booDelete Then
            .Delete
         Else
            If appt.dtmRecurrenceEnds = 0 Then
               .Start = appt.dtmStart
               If appt.booAllDayEvent Then
                  .AllDayEvent = True
               Else
                  .AllDayEvent = False
                  .Duration = appt.lngDuration
                  '.End = appt.dtmEnd
               End If
            Else
               Set outRecurrPatt = .GetRecurrencePattern
               With outRecurrPatt
                   .RecurrenceType = olRecursDaily
                   .PatternStartDate = DateSerial(Year(appt.dtmStart), Month(appt.dtmStart), Day(appt.dtmStart))
                   .PatternEndDate = DateSerial(Year(appt.dtmRecurrenceEnds), Month(appt.dtmRecurrenceEnds), Day(appt.dtmRecurrenceEnds))
                   .StartTime = TimeSerial(Hour(appt.dtmStart), Minute(appt.dtmStart), Second(appt.dtmStart))
                   If appt.booAllDayEvent Then
                      .Duration = 1440
                   Else
                      .Duration = appt.lngDuration
                   End If
                   
               End With
           
           
            End If
           
            .Subject = appt.strSubject
            .Categories = appt.strCategories
            .Body = appt.strBody
            .Location = appt.strLocation
         
            If appt.lngReminderMinutesBeforeStart <= 0 Then
               .ReminderSet = False
            Else
               .ReminderSet = True
               .ReminderMinutesBeforeStart = appt.lngReminderMinutesBeforeStart
               .ReminderOverrideDefault = True
               .ReminderPlaySound = True
 '              .ReminderSoundFile = SysCmd(acSysCmdAccessDir) & "Reminder.wav"
            End If
         
            .Save
            If Val(.OutlookVersion) >= 12 And appt.strGlobalAppointmentID = "" Then appt.strGlobalAppointmentID = .GlobalAppointmentID
            If appt.strEntryID = "" Then appt.strEntryID = .EntryID
         End If
    End With
   
    ' Release the Outlook object variable.
    Set outobj = Nothing
     
AddAppt_Exit:
    Exit Function
 
AddAppt_Err:
    Select Case Err
        Case Else
             strMSG = "An unexpected error has oocurred in AddAppt" & vbCrLf & vbCrLf & _
                      "Error " & vbTab & "Description" & vbCrLf & _
                      Err.Number & vbTab & Err.Description
             Select Case MsgBox(strMSG, vbCritical + vbAbortRetryIgnore, "Error in AddAppt")
                 Case vbAbort:  Resume AddAppt_Exit
                 Case vbIgnore: Resume Next
                 Case vbRetry:  Resume
             End Select
    End Select
 
End Function
 
Sub TestAppointment()
Dim appt As aiAppointment
 
'Create a new appointment
    With appt
        .dtmStart = Now() + 1
'        .dtmRecurrenceEnds = .dtmStart + 28
        .booAllDayEvent = True
'        .lngDuration = 30
        .lngReminderMinutesBeforeStart = 10
'        .strLocation = "Home"
        .strSubject = "Test Subject"
        .strFolder = "NAEP Background Questionnaire - Calendar"
    End With
    OutlookAppointment appt
    MsgBox "Appointment Created"
   
' Update the appointment
    With appt
        .strBody = Format(Now(), "dd mmmm yyyy hh:nn") & " Test Data Update"
    End With
    OutlookAppointment appt
    MsgBox "Appointment Updated"
   
' delete the appointment
    With appt
        .booDelete = True
    End With
    OutlookAppointment appt
    MsgBox "Appointment Deleted"
 
End Sub
LVL 2
stevefrieseAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

stevefrieseAuthor Commented:
I found out how.

 Set outFolder = outNameSpace.Folders.Item("SharePoint Lists")
Set outFolder = outFolder.Folders("name of calendar")
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.