Excel VBA to set an outlook appointment

[ArtemisApollo2021]

Hello,

I am trying to find a VBA for to make a scheduling tool. The schedule is set to be from 8:00am to 8:00pm in half hour intervals. Is there a way to make it so if the 8:00am through 9:00am and then from 10:00am through 11:00am are checked it will setup two different appointments? This would need to have each day of the week on the same sheet. The time would start in cell C9 ending at C32. Any assistance you can provide would be very much appreciated.

 

[Micron]

I had to research for code to create calendar appointments from a list of column A names and B dates. Maybe you can modify to alter parameters such as whether or not the item has a recurrence pattern. I suppose you won't want that. This should also point to what objects might have other properties that you need (e.g. IPM.Appointment).

Sub ImportBirthdaysToCalendar()
    Dim objWorksheet As Excel.Worksheet
    Dim nRow As Integer, nLastRow As Integer
    Dim objOutlookApp As Outlook.Application
    Dim objCalendar As Outlook.Folder
    Dim objBirthdayEvent As Outlook.AppointmentItem
    Dim objRecurrencePattern As Outlook.RecurrencePattern
 
    'Get the specific sheet
    Set objWorksheet = ThisWorkbook.Sheets(1)
    nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
 
    Set objOutlookApp = CreateObject("Outlook.Application")
    Set objCalendar = objOutlookApp.Session.GetDefaultFolder(olFolderCalendar)
 
    For nRow = 2 To nLastRow
        Set objBirthdayEvent = objCalendar.Items.Add("IPM.Appointment")
 
        'Create birthday events
        With objBirthdayEvent
            .Subject = objWorksheet.Range("A" & nRow) & Chr(39) & "s Birthday"
            .Body = "Born " & Format(Int(objWorksheet.Range("B" & nRow)), "mmmm dd, yyyy")
            .AllDayEvent = False
            .Start = objWorksheet.Range("B" & nRow)
            .BusyStatus = olFree
            .ReminderSet = True
            .ReminderMinutesBeforeStart = 4320
         Set objRecurrencePattern = .GetRecurrencePattern
         With objRecurrencePattern
            .RecurrenceType = olRecursYearly
            .PatternStartDate = objWorksheet.Range("B" & nRow)
            .NoEndDate = True
         End With
            .Save
        End With
    Next
End Sub