Instantly share code, notes, and snippets.

Embed
What would you like to do?
Outlook course management macro
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment