Help with coding (adding appointments to outlook shared calendar)

[zoog25]

Hello all,

I'm been having trouble researching this information on the internet but i have developed the code with some help and have it working perfectly, but it only adds appointments to my calendar. The program needs to add appointments to a specific calendar titled "Bid Schedule" and it is found on person x's mailbox. Here is what i have so far in coding:

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 = "xxxx@xxxxx.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

Please let me know what i need to do in order to have the above code add appointments to a shared calendar. Thanks.

 

[zoog25]

bump