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.