Create meeting in Public Folder calendar with recipient via VBA

[Be_Dang3rous]

Good Morning,

I keep hitting road block after road block trying to modify my below code to create the meetings in a public folder calendar instead of my own calendar. I would be forever greatful if anyone could help me. Basically I have a userform that will have a StartDate and an EndDate field that sets recurring 30 minute meetings from 7 AM to 6 PM on a calendar and a recipients calendar (the reason for this need still has not been explained to me but I am just going with it). I am now trying to change the below working code to create the meeting in a public folder calendar automatically and not my own.

I have tried the GetFolder function but I cannot get it to work and keep receiving an Error message about missing variables.

Here is the code I am starting with

Set Start = ReservationAutomation.StartDateSet EndOn = ReservationAutomation.EndDate
Const olAppointmentItem = 1
Const olRecursDaily = 0
Dim myRequiredAttendee, myOptionalAttendee, myResourceAttendee As Outlook.Recipient


'7 AM


Set objOutlook = CreateObject("Outlook.Application")
Set ObjAppointment = objOutlook.CreateItem(olAppointmentItem)
ObjAppointment.MeetingStatus = olMeeting
ObjAppointment.Start = StartDate & " 7:00:00 AM"
ObjAppointment.Duration = 30
ObjAppointment.Recipients.Add("3035 -Lync")
ObjAppointment.Subject = "Blocked"
'objAppointment.Body = ""
'objAppointment.Location = "3035 -Lync"
Set objRecurrence = ObjAppointment.GetRecurrencePattern
objRecurrence.RecurrenceType = olRecursDaily
objRecurrence.PatternStartDate = StartDate
objRecurrence.PatternEndDate = EndDate
 
ObjAppointment.Save

Thank you once again

[Be_Dang3rous]

I was able to figure this out using the below Code:

Public Function GetPublicFolder(strFolderPath)
    
    Dim colFolders
    Dim objFolder
    Dim arrFolders
    Dim i
    On Error Resume Next
    strFolderPath = Replace(strFolderPath, "/", "\")
    arrFolders = Split(strFolderPath, "\")
     
    Set objFolder = Application.Session.GetDefaultFolder(18)
    Set objFolder = objFolder.Folders.item(arrFolders(0))
    If Not objFolder Is Nothing Then
        For i = 1 To UBound(arrFolders)
            Set colFolders = objFolder.Folders
            Set objFolder = Nothing
            Set objFolder = colFolders.item(arrFolders(i))
            If objFolder Is Nothing Then
                Exit For
            End If
        Next
    End If
    Set GetPublicFolder = objFolder
    Set colFolders = Nothing
     Set objApp = Nothing
    Set objFolder = Nothing
End Function

Sub BlockCalendar()
Set Start = ReservationAutomation.StartDate
    Set EndOn = ReservationAutomation.EndDate
    Dim golApp As Outlook.Application
    Dim fldFolder As MAPIFolder
    Dim strPublicFolder As String
    Dim obj As AppointmentItem
    Const olAppointmentItem = 1
    Const olRecursDaily = 0
    
    '7:00 AM


    Set golApp = New Outlook.Application
    
    strPublicFolder = "Path to Public folder without leading \\"
            
    Set fldFolder = GetPublicFolder(strPublicFolder)


    Set obj = fldFolder.Items.Add(olAppointmentItem)
    obj.MeetingStatus = olMeeting


    With obj
        .Start = StartDate & " 7:00:00 AM"
        .Duration = 30
        .Recipients.Add ("3035 -Lync")
        .Subject = "Blocked - Contact Admin"
        .Location = "3035 -Lync"
    Set objRecurrence = obj.GetRecurrencePattern
    objRecurrence.RecurrenceType = olRecursDaily
    objRecurrence.PatternStartDate = StartDate
    objRecurrence.PatternEndDate = EndDate


        .Send
    End With
End Sub

I then expanded the code to create multiple 30 minute blocks within the Block Calendar macro.