Acces shared callendar and use excel information to add appointment

[Masterkale]

Hello people i have a code working that will shoot appointments into my default calendar and delete the old ones. But now i would like to shoot them from my pc into my collegues their pc. I tried to search on GetSharedDefaultFolder but i cant solve this. (was getting runtime errors 438 etc.) Can somebody help me?

Public Sub CommandButton21_Click()
' delete all orders with #(^)#
deleteOutlookAppt

' Create the Outlook session
    Set myOutlook = CreateObject("Outlook.Application")
Worksheets("Uitvoerder").Select
    ' Start at row 2
    r = 2
    Do Until Trim(Cells(r, 1).Value) = ""
        ' Create the AppointmentItem
        Set myApt = myOutlook.CreateItem(1)
        ' Set the appointment properties
        myApt.Subject = Cells(r, 15).Value
        myApt.Location = Cells(r, 17).Value
        myApt.Start = Cells(r, 18).Value
        myApt.Duration = Cells(r, 6).Value
        myApt.Categories = Cells(r, 10).Value
        ' If Busy Status is not specified, default to 2 (Busy)
        If Trim(Cells(r, 8).Value) = "" Then
            myApt.BusyStatus = 2
        Else
            myApt.BusyStatus = Cells(r, 8).Value
        End If
        If Cells(r, 7).Value > 0 Then
            myApt.ReminderSet = True
            myApt.ReminderMinutesBeforeStart = Cells(r, 7).Value
        Else
            myApt.ReminderSet = False
        End If
        myApt.Body = Cells(r, 13).Value
        myApt.Save
        r = r + 1
    Loop
    
    MsgBox "De orders zijn naar outlook gekopieerd."
End Sub


Sub deleteOutlookAppt()
Dim olApp As Object 'Outlook.Application
Dim olNS As Object 'Outlook.Namespace
Dim olAptItemFolder As Object 'Outlook.Folder
Dim olAptItem As Object 'Outlook.AppointmentItem
Dim i As Long
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.Session
    Set olAptItemFolder = olNS.GetDefaultFolder(9) '9=olFolderCalendar constant
    
    For i = olAptItemFolder.Items.Count To 1 Step -1
        Set olAptItem = olAptItemFolder.Items(i)
        If olAptItem.Subject Like "*(^)*" Then
            olAptItem.Delete
        End If
    Next i
    
    Set olAptItem = Nothing
    Set olAptItemFolder = Nothing
    Set olApp = Nothing
    
End Sub

 

[Masterkale]

I got it working... But now i only need to add a delete function to delete double appointments in a shared calendar

Sub CreateOtherUserAppointment()


Dim objApp As Outlook.Application
Dim objNS As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Dim objDummy As Outlook.MailItem
Dim objRecip As Outlook.Recipient
Dim objAppt As Outlook.AppointmentItem
Dim strMsg As String
Dim strName As String
On Error Resume Next


' ### name of person whose Calendar you want to use ###


strName = "Koeleman Kees"


Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objDummy = objApp.CreateItem(olMailItem)
Set objRecip = objDummy.Recipients.Add(strName)
objRecip.Resolve
If objRecip.Resolved Then
On Error Resume Next
Set objFolder = _
objNS.GetSharedDefaultFolder(objRecip, _
olFolderCalendar)
If Not objFolder Is Nothing Then
Set objAppt = objFolder.Items.Add
If Not objAppt Is Nothing Then
With objAppt


Worksheets("Uitvoerder").Select


    ' Start at row 2
    r = 2
Do Until Trim(Cells(r, 1).Value) = ""
.Subject = Cells(r, 15)
.Start = Cells(r, 18)
.Duration = Cells(r, 6)
.Location = Cells(r, 17)
.Categories = Cells(r, 10)
.BusyStatus = Cells(r, 8)
.ReminderMinutesBeforeStart = Cells(r, 7)
.Body = Cells(r, 13)
   r = r + 1
    Loop
.Save
End With
End If
End If
Else
MsgBox "Could not find " & Chr(34) & strName & Chr(34), , _
"User not found"
    End If
    Set objApp = Nothing
    Set objNS = Nothing
    Set objFolder = Nothing
    Set objDummy = Nothing
    Set objRecip = Nothing
    Set objAppt = Nothing
    MsgBox "De orders zijn naar outlook gekopieerd."
End Sub