Outlook course management macro

OutlookCourseMgmt.vb

Option Explicit
' See https://geelaw.blog/entries/course-mgmt-outlook/

Dim termStartsOn As Date, curriculumCalendar As Folder

Sub AskForTermStartsOn()

    Dim shouldAskNewDate As Boolean

TryAskNewDate:
    On Error GoTo TryAskNewDate
    If termStartsOn < #1/1/2016# Then
        termStartsOn = Now
        shouldAskNewDate = True
    End If
    If Not shouldAskNewDate Then
        shouldAskNewDate = (MsgBox("The term starts on " & termStartsOn & ". Would you like to pick a new date?", vbYesNo + vbDefaultButton2) = vbYes)
    End If
    If shouldAskNewDate Then
        termStartsOn = DateValue(CDate(InputBox("Please specify the date on which the term starts." & vbCrLf & vbCrLf & "A term must start on a Monday.", , termStartsOn)))
        If Weekday(termStartsOn, vbMonday) = 1 Then
            shouldAskNewDate = False
        End If
        GoTo TryAskNewDate
    End If

End Sub

Sub AskForCurriculumCalendar()

    Dim shouldAskNewCalendar As Boolean

TryAskNewCalendar:
    On Error GoTo TryAskNewCalendar
    If curriculumCalendar Is Nothing Then
        Set curriculumCalendar = Outlook.Application.Session.GetDefaultFolder(olFolderCalendar)
        shouldAskNewCalendar = True
    End If
    If Not shouldAskNewCalendar Then
        shouldAskNewCalendar = (MsgBox("The events will be stored in " & curriculumCalendar.Name & ". Would you like to pick a new folder?", vbYesNo + vbDefaultButton2) = vbYes)
    End If
    If shouldAskNewCalendar Then
        Set curriculumCalendar = Outlook.Application.Session.PickFolder
        If curriculumCalendar Is Nothing Then Exit Sub
        If curriculumCalendar.DefaultItemType = olAppointmentItem Then
            shouldAskNewCalendar = False
        Else
            MsgBox "The folder you pick must be a calendar folder. Try picking another one.", vbExclamation
        End If
        GoTo TryAskNewCalendar
    End If

End Sub

Function ThreeLetterToWeekday(i As String) As Integer

    ThreeLetterToWeekday = -1

    Select Case UCase(i)
        Case "MON"
            ThreeLetterToWeekday = 0
        Case "TUE"
            ThreeLetterToWeekday = 1
        Case "WED"
            ThreeLetterToWeekday = 2
        Case "THU"
            ThreeLetterToWeekday = 3
        Case "FRI"
            ThreeLetterToWeekday = 4
        Case "SAT"
            ThreeLetterToWeekday = 5
        Case "SUN"
            ThreeLetterToWeekday = 6
    End Select

End Function


Sub CreateCourse()

    AskForCurriculumCalendar
    If curriculumCalendar Is Nothing Then Exit Sub
    AskForTermStartsOn

    Dim courseName As String
    Dim courseDescription As String
    Dim courseLocation As String
    Dim courseStartsAt() As Date
    Dim courseDurationMinutes() As Integer
    Dim countTillNow As Integer
    Dim courseReminderMinutes As Integer
    Dim courseInstanceString As String
    Dim courseInstanceHelper1() As String
    Dim courseInstanceHelper2() As String
    Dim lowerWeek As Integer, upperWeek As Integer
    Dim startMinute As Integer, endMinute As Integer
    Dim instanceWeekday As Integer
    Dim i As Integer
    Dim concatInstanceStrings As String
    Dim appointment As AppointmentItem
    
    countTillNow = 0

    courseName = Trim(InputBox("Please specify the name of this course."))
    If Trim(courseName) = "" Then Exit Sub
    
    courseDescription = Trim(InputBox("Please specify the description of this course."))
    
    courseLocation = Trim(InputBox("Please specify the location of this course.", , "To be announced"))
    If courseLocation = "" Then Exit Sub
    
    courseReminderMinutes = 15
    ' Currently, this is hardcoded.
    
    On Error GoTo TryAgainPrompt
TryAgain:
    Do
        courseInstanceString = Trim(InputBox("Please specify the instances of this course." & vbCrLf & vbCrLf & "E.g., 1-16,Mon,8:00-9:50."))
        If courseInstanceString = "" Then Exit Do
        
        courseInstanceHelper1 = Split(courseInstanceString, ",")
        
        instanceWeekday = ThreeLetterToWeekday(courseInstanceHelper1(1))
        If instanceWeekday = -1 Then GoTo TryAgainPrompt
        
        courseInstanceHelper2 = Split(courseInstanceHelper1(0), "-")
        lowerWeek = CInt(courseInstanceHelper2(0))
        upperWeek = CInt(courseInstanceHelper2(1))
        If lowerWeek < 1 Or upperWeek > 20 Or lowerWeek > upperWeek Then GoTo TryAgainPrompt
        
        courseInstanceHelper2 = Split(courseInstanceHelper1(2), "-")
        courseInstanceHelper1 = Split(courseInstanceHelper2(0), ":")
        startMinute = CInt(courseInstanceHelper1(0)) * 60 + CInt(courseInstanceHelper1(1))
        courseInstanceHelper1 = Split(courseInstanceHelper2(1), ":")
        endMinute = CInt(courseInstanceHelper1(0)) * 60 + CInt(courseInstanceHelper1(1))
        
        If startMinute < 0 Or startMinute > endMinute Then GoTo TryAgainPrompt
        
        ReDim Preserve courseStartsAt(1 To countTillNow + (upperWeek - lowerWeek + 1))
        ReDim Preserve courseDurationMinutes(1 To countTillNow + (upperWeek - lowerWeek + 1))
        
        For i = lowerWeek To upperWeek
            countTillNow = countTillNow + 1
            courseStartsAt(countTillNow) = DateAdd("n", startMinute, DateAdd("d", (i - 1) * 7 + instanceWeekday, termStartsOn))
            courseDurationMinutes(countTillNow) = endMinute - startMinute
        Next i
        
        concatInstanceStrings = concatInstanceStrings & vbCrLf & courseInstanceString
    Loop While True
    
    If MsgBox("The following is a summary of the course to be added:" & vbCrLf & vbCrLf & _
        "Stored in " & curriculumCalendar.Name & vbCrLf & _
        "Term starts on " & termStartsOn & vbCrLf & _
        courseName & " @ " & courseLocation & vbCrLf & _
        courseDescription & vbCrLf & _
        "Time:" & vbCrLf & concatInstanceStrings & vbCrLf & vbCrLf & _
        "Is that okay?", vbQuestion + vbYesNo) = vbNo Then Exit Sub
    
    On Error GoTo Fail
    
    For i = 1 To countTillNow
        Set appointment = curriculumCalendar.Items.Add(olAppointmentItem)
        appointment.Subject = courseName
        appointment.Body = courseDescription
        appointment.Location = courseLocation
        appointment.ReminderOverrideDefault = True
        appointment.ReminderMinutesBeforeStart = courseReminderMinutes
        appointment.ReminderSet = True
        appointment.AllDayEvent = False
        appointment.StartInStartTimeZone = courseStartsAt(i)
        appointment.EndInEndTimeZone = DateAdd("n", courseDurationMinutes(i), courseStartsAt(i))
        appointment.BusyStatus = olBusy
        appointment.Save
        Set appointment = Nothing
    Next i
    
    MsgBox "The course instances are added.", vbInformation
    
    Exit Sub
    
Fail:
    MsgBox "Something went wrong.", vbCritical
    Exit Sub

TryAgainPrompt:
    MsgBox "You entered " & courseInstanceString & ", which is invalid. Please try again.", vbExclamation
    GoTo TryAgain

End Sub