Hello all,

This is my first time posting on this forum but i've been spending days on end trying to finish up a program for my office. In it's current state it works fine except for teh fact that i can't get it to add new appointments onto a shared calendar. This is my code i have:
Code:
Option Explicit

Sub AddToOutlook()

Dim OL As Outlook.Application
Dim olAppt As Outlook.AppointmentItem
Dim NS As Outlook.Namespace
Dim oFolder As Outlook.Folder
Dim oRecipient As Outlook.Recipient
Dim r As Long, i As Long, sSubject As String, sBody As String, sLocation As String
Dim BID As String
Dim dStartTime As Date, dEndTime As Date
Dim bOLOpen As Boolean

'Checks to see if Outlook is open and either open and closes it or leaves it open
On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
bOLOpen = True

If OL Is Nothing Then
    Set OL = CreateObject("Outlook.Application")
        bOLOpen = False
End If

'Updates Outlook Calendar
r = Range("B" & Rows.Count).End(xlUp).Row

For i = 16 To r

    If Range("C" & i).Value = "" Then
        Range("C" & i).Value = Range("D" & i).Value
    End If
    
    If Range("B" & i).Value <> " " Then
        sSubject = Range("A" & i).Value & " " & ":" & " " & Range("G" & i).Value
        sLocation = Range("H16").Value
        
        If Range("E" & i).Value = "" Then
            dStartTime = Range("D" & i).Value + #5:00:00 PM#
            dEndTime = Range("D" & i).Value + #5:00:00 PM#
        ElseIf Range("E" & i).Value = "EOD" Then
            dStartTime = Range("D" & i).Value + #5:00:00 PM#
            dEndTime = Range("D" & i).Value + #5:00:00 PM#
        Else
            dStartTime = Range("D" & i).Value + Range("E" & i).Value
            dEndTime = Range("D" & i).Value + Range("E" & i).Value
        End If
        
        If Range("B" & i).Value = "U" Then
            BID = Range("A" & i).Value
            DeleteOldBidEntry (BID)
        End If
        
        
        Set olAppt = OL.CreateItem(olAppointmentItem)
            
            olAppt.Subject = sSubject
            olAppt.Location = sLocation
            olAppt.Start = dStartTime
            olAppt.End = dEndTime
            olAppt.Categories = "BID"
            olAppt.ReminderSet = True
            olAppt.MeetingStatus = olMeeting
            'olAppt.RequiredAttendees = "louis@kernsteel.com"
            olAppt.Send
            olAppt.Close olSave
     

        If bOLOpen = False Then OL.Quit
        Range("B" & i).Value = " "
    End If
Next i

End Sub

Sub DeleteOldBidEntry(BID As String)
    
    Dim olapp As Outlook.Application
    Dim OLF As Outlook.MAPIFolder
    Dim olItm As Outlook.AppointmentItem

    On Error Resume Next
    Set olapp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If olapp Is Nothing Then
        On Error Resume Next
        Set olapp = GetObject("Outlook.Application")
        On Error GoTo 0
        If olapp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If
    Set OLF = olapp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
    
    'Find calendar event by subject
    Set olItm = OLF.Items.Find("[Subject] = '" & sSubject & "'")
    If Not TypeName(olItm) = "Nothing" Then
        olItm.Delete
        MsgBox "Bid item: " & vbLf & vbLf & sSubject, , "Calendar Event Deleted"
    Else
        MsgBox "Cannot find calendar item: " & vbLf & vbLf & sSubject, , "Calendar Event Not Found"
    End If
    
    Set olapp = Nothing
    Set OLF = Nothing
    
End Sub
the calendar that i'm trying to attach this to is located on another person's mailbox. Here is the calendars location info: Mailbox - Sale Manager. and the calendar is called "Bid Schedule".

Please someone help me with this.