' Use at your own risk. The code below is provided "AS IS" with no warranty made as to technical accuracy and confers no rights.
' Do not make any business decisions based on the output of the code below. Always test on a copy of the original mpp file.
' Do not redistribute.
'
' © Ismet Kocaman | ismetkocaman.com

' IMPORTANT NOTE: Update the following statement in the subroutine ListResourceCalendars_v2 according to 
'                 the active project plan's start and finish dates:
'                 ListNonDefaultTimes Res.Calendar, #1/1/2020#, #1/1/2025#

' Use the following subroutine ListBaseCalendars to produce a list of all the base calendars
' in a project plan file.

Option Explicit

Dim MainStr As String

Sub ListBaseCalendars()
    
    Dim BaseCal As Calendar
       
      
    For Each BaseCal In ActiveProject.BaseCalendars
           
           MainStr = ""

           'Get the base calendar's details
           GetWeekDaysWorkWeeks BaseCal
           GetExceptions BaseCal

           'Display the base calendar's details
           'See the Immediate Window
           Debug.Print "BASE CALENDAR: " & BaseCal.Name & vbCrLf & MainStr
   
    Next BaseCal

End Sub

'GetWeekDaysWorkWeeks -- Feeds MainStr with the details of default workweek
'                        and any additional non-default work weeks
Sub GetWeekDaysWorkWeeks(cal As Calendar)
    
    Dim i As Long, j As Long, k As Long
    Dim Str As String
    Dim WD As Weekday
    Dim WWD As WorkWeekDay
        
    'Get the details of the default work week
    Str = Str & "-- Work Weeks (Default)" & vbCrLf
    i = ActiveProject.StartWeekOn
    For j = 1 To cal.WeekDays.Count
        With cal.WeekDays(i)
             Str = Str & "   " & UCase(Left(.Name, 2))
             If .Working Then
                Str = Str & Get_Shifts(cal.WeekDays(i))
             Else
                Str = Str & ", Nonworking"
             End If
                Str = Str & vbCrLf
        End With
        i = i + 1
        If (i > 7) Then i = 1
    Next j
                 
    'Get the details of the non-default work weeks
    If cal.WorkWeeks.Count <> 0 Then
       Str = Str & vbCrLf & "-- Work Weeks (non-default)" & vbCrLf
       For j = 1 To cal.WorkWeeks.Count
           Str = Str & "   " & cal.WorkWeeks(j).Name & ", " & _
                 Format(cal.WorkWeeks(j).Start, "mm/dd/yy") & ", " & _
                 Format(cal.WorkWeeks(j).Finish, "mm/dd/yy") & vbCrLf
           i = ActiveProject.StartWeekOn
           For k = 1 To cal.WorkWeeks(j).WeekDays.Count
               With cal.WorkWeeks(j).WeekDays(i)
                    Str = Str & "   " & UCase(Left(.Name, 2))
                    If .Working Then
                       Str = Str & Get_Shifts(cal.WorkWeeks(j).WeekDays(i))
                    Else
                       Str = Str & ", Nonworking"
                    End If
                    Str = Str & vbCrLf
               End With
               i = i + 1
               If (i > 7) Then i = 1
           Next k
       Next j
    End If
    MainStr = MainStr & Str & vbCrLf
End Sub

Sub GetExceptions(cal As Calendar) 'GetExceptions -- Feeds MainStr with the details of exceptions

    Dim j As Long
    Dim Str As String
    
    'Get the exception information
    Str = "-- Exceptions"
    MainStr = MainStr & Str & vbCrLf
    With cal
         If .Exceptions.Count <> 0 Then
            For j = 1 To .Exceptions.Count
                Str = "   " & .Exceptions(j).Name & ", " & _
                      Format(.Exceptions(j).Start, "mm/dd/yy") & ", " & _
                      Format(.Exceptions(j).Finish, "mm/dd/yy")
                MainStr = MainStr & Str & vbCrLf
                'Get the exception's details
                IdentifyExceptionPattern .Exceptions(j), cal
            Next j
         Else
            Str = "   None"
            MainStr = MainStr & Str & vbCrLf
         End If
    End With
End Sub
Sub IdentifyExceptionPattern(E As Exception, cal As Calendar)
    
    Dim i As Long, j As Long
    Dim Period As Long
    Dim DaysinWeek As Long, LastDay1stWeek As Long
    Dim k As Date
    Dim Str As String
    Dim ExceptionDays As String
 
    Select Case E.Type
    
    Case pjDaily, pjDayCount
         
         If E.Period = 0 Then
            Period = 1
         Else
            Period = E.Period
         End If

         'Get the exception's pattern information
         Str = "   Period: " & E.Period & " Occurs: " & E.Occurrences
         MainStr = MainStr & Str & vbCrLf
         'Get the occurrences
         For k = E.Start To E.Finish
             If (Int(k) - Int(E.Start)) Mod Period = 0 Then
                GetExceptionDetails CDate(k), E, cal
             End If
         Next k
   
    Case pjWeekly
 
         Str = ""
         ExceptionDays = ""
         
         'In order to use in tests create a string of the selected weekdays
         'The associated checboxes always start on Sunday (factory setting)
         For i = 1 To 7
             If (E.DaysOfWeek And Choose(i, &H1&, &H2&, &H4&, &H8&, &H10&, &H20&, &H40&)) Then
                ExceptionDays = ExceptionDays & WeekdayName(i, True, pjSunday) & ", "
             End If
         Next i
         
         'Get the exception's pattern information
         Str = "   Days: " & ExceptionDays & "Period: " & E.Period & ", Occurs: " & E.Occurrences
         MainStr = MainStr & Str & vbCrLf
         
         'Find the first week's occurrences
         DaysinWeek = 0
         For i = Weekday(E.Start, ActiveProject.StartWeekOn) To 7
             If InStr(1, ExceptionDays, Format(E.Start + DaysinWeek, "ddd")) Then
                GetExceptionDetails CDate(E.Start + DaysinWeek), E, cal
             End If
             DaysinWeek = DaysinWeek + 1
         Next i
         LastDay1stWeek = E.Start + DaysinWeek
 
         'Find the other weeks' occurrences
         For i = LastDay1stWeek To E.Finish Step 7
             'Locate the next period's week
             If ((i - LastDay1stWeek) / 7 + 1) Mod E.Period = 0 Then
                'i is now the 1st day of the week. Scan the week starting on the date i
                DaysinWeek = 0
                For j = 1 To 7
                    If InStr(1, ExceptionDays, Format(i + DaysinWeek, "ddd")) Then
                       GetExceptionDetails CDate(i + DaysinWeek), E, cal
                    End If
                    DaysinWeek = DaysinWeek + 1
                    If i + DaysinWeek > E.Finish Then Exit For
                Next j
             End If
         Next i
     
    Case pjMonthlyMonthDay
           
         'Get the exception's pattern information
         Str = "   Day " & E.MonthDay & " of every " & E.Period & " months" & ", Occurs: " & E.Occurrences
         MainStr = MainStr & Str & vbCrLf
         'Get the occurrences
         For k = E.Start To E.Finish
             If Day(k) = E.MonthDay And _
                ((Year(k) * 12 + Month(k)) - (Year(E.Start) * 12 + Month(E.Start))) Mod E.Period = 0 Then
                GetExceptionDetails CDate(k), E, cal
             End If
         Next k

    Case pjMonthlyPositional
            
         'The weekday selection dropdown in the dialog box lists the weekdays starting from Monday but
         'they must always be counted starting from Sunday in calculations (factory setting)

         'Get the exception's pattern information
         Str = "   The " & Choose(E.MonthPosition + 1, "First", "Second", "Third", "Fourth", "Last") & _
               " " & WeekdayName(E.MonthItem - 2, True, pjSunday) & " of every " & E.Period & " months" _
               & ", Occurs: " & E.Occurrences
         MainStr = MainStr & Str & vbCrLf
         'Get the occurrences
         For k = E.Start To E.Finish
             If nthXDayofMonth(E.MonthPosition + 1, E.MonthItem - 2, _
                               DateSerial(Year(k), Month(k), Day(k))) = k And _
                ((Year(k) * 12 + Month(k)) - (Year(E.Start) * 12 + Month(E.Start))) Mod E.Period = 0 Then
                GetExceptionDetails CDate(k), E, cal
             End If
         Next k
    Case pjYearlyPositional
       
         'Get the exception's pattern information
         Str = "   The " & _
               Choose(E.MonthPosition + 1, "First", "Second", "Third", "Fourth", "Last") & _
               " " & WeekdayName(E.MonthItem - 2, True, pjSunday) & " of " & _
               MonthName(E.Month) & ", Occurs: " & E.Occurrences
         MainStr = MainStr & Str & vbCrLf
         'Get the occurrences
         For k = E.Start To E.Finish
             If nthXDayofMonth(E.MonthPosition + 1, E.MonthItem - 2, _
                DateSerial(Year(k), E.Month, Day(k))) = k Then
                GetExceptionDetails CDate(k), E, cal
             End If
         Next k
 
    Case pjYearlyMonthDay
       
         'Get the exception's pattern information
         Str = "   " & MonthName(E.Month) & " " & E.MonthDay _
               & ", Occurs: " & E.Occurrences
         MainStr = MainStr & Str & vbCrLf
         'Get the occurrences
         For k = E.Start To E.Finish
             If k = DateSerial(Year(k), E.Month, E.MonthDay) Then
                GetExceptionDetails CDate(k), E, cal
             End If
         Next k

    End Select
    MainStr = MainStr & vbCrLf
End Sub

Sub GetExceptionDetails(k As Date, E As Exception, cal As Calendar)
                 
    Dim Str As String
       
    Str = "   " & Format(k, "ddd mmm dd, yyyy")
    With cal.Period(k)
         If .Working Then
             Str = Str & Get_Shifts(cal.Period(k))
         Else
             Str = Str & ", Nonworking"
         End If
    End With
    MainStr = MainStr & Str & vbCrLf
End Sub

'In monthly and yearly positional exception calculations the nthXDayofMonth function is used.
'nthXDayofMonth returns the nth occurrence of a weekday selected in a month specified. The weekday
'selection dropdown in the Details dialog box lists the weekdays starting from Monday but
'they must always be counted starting from Sunday in calculations (factory setting)
Function nthXDayofMonth(nth As Long, Day_x As Long, d As Date) As Date
 
    Dim FirstDayofMonth As Long, LastDayofMonth As Long
 
    If nth = 5 Then
       LastDayofMonth = DateSerial(Year(d), Month(d) + 1, 0)
       nthXDayofMonth = LastDayofMonth + 1 - Weekday(LastDayofMonth + 1 - Day_x, pjSunday)
    Else
       FirstDayofMonth = d - Day(d) + 1
       nthXDayofMonth = FirstDayofMonth + 7 * nth - Weekday(FirstDayofMonth - Day_x, pjSunday)
    End If
End Function

' Use the following subroutine ListResourceCalendars_v2 to produce a list of all the resource calendars
' in a project plan file.

Sub ListResourceCalendars_v2()
    
    Dim Str As String
    Dim Res As Resource
           
    For Each Res In ActiveProject.Resources
        If Not (Res Is Nothing) And Res.Type = pjResourceTypeWork Then
       

           'Insert the work resource's information
           'Adjust the date range according to the project's start and finish dates
           Str = vbCrLf & "[" & Res.ID & "] " & Res.Name & " (Base Calendar: " & Res.BaseCalendar & ")"
           'See the Immediate Window
           Debug.Print Str
              
           ListDefaultWorkWeek Res.Calendar
           'Adjust the date range according to the project's start and finish dates
           ListNonDefaultTimes Res.Calendar, #1/1/2020#, #1/1/2025#
            
           End If
    Next Res
End Sub

Sub ListDefaultWorkWeek(cal As Calendar)
    
    Dim i As Long, j As Long
    Dim Str As String
    Dim WD As Weekday
        
    'Display the header
    'See the Immediate Window
    Debug.Print "-- Default Work Week"
        
    'List default work week details on the resource's calendar
    i = ActiveProject.StartWeekOn
    For j = 1 To cal.WeekDays.Count
        With cal.WeekDays(i)
             Str = "   " & UCase(Left(.Name, 2))
             If .Working Then
                Str = Str & Get_Shifts(cal.WeekDays(i))
             Else
                Str = Str & ", Nonworking"
             End If
        End With
        'See the Immediate Window
        Debug.Print Str
        i = i + 1
        If (i > 7) Then i = 1
     Next j
End Sub
    
Sub ListNonDefaultTimes(cal As Calendar, Start As Date, Finish As Date)

    Dim S1 As String, S2 As String, Str As String
    Dim i As Date
    
    Str = "-- Non-default Working/Nonworking Days"
    'See the Immediate Window
    Debug.Print vbCrLf & Str
  
    For i = Start To Finish
    
        With cal.Period(i)
    
             'Find effective non-working day overriding working days in the default work week
             If .Working = False And cal.WeekDays(Weekday(i)).Working = True Then
                Str = "   " & Format(i, "ddd mmm dd, yyyy") & ", Nonworking"
                'See the Immediate Window
                Debug.Print Str
             End If

             'Create the shift patterns for comparison
             S1 = .Shift1.Start & .Shift1.Finish & .Shift2.Start & .Shift2.Finish & .Shift3.Start & _
                  .Shift3.Finish & .Shift4.Start & .Shift4.Finish & .Shift5.Start & .Shift5.Finish
             With cal.WeekDays(Weekday(i))
                  S2 = .Shift1.Start & .Shift1.Finish & .Shift2.Start & .Shift2.Finish & .Shift3.Start & _
                       .Shift3.Finish & .Shift4.Start & .Shift4.Finish & .Shift5.Start & .Shift5.Finish
             End With
             'Find effective working days overriding non-working days in the default work week
             If .Working = True And S1 <> S2 Then
                Str = "   " & Format(i, "ddd mmm dd, yyyy") & Get_Shifts(cal.Period(i))
                'See the Immediate Window
                Debug.Print Str
             End If
        End With
    Next i
End Sub

'GetShifts returns a string containing formatted pattern of shift times
Function Get_Shifts(Shifts As Object) As String

         Dim Str As String

         With Shifts
              Str = BuildString(.Shift1.Start, .Shift1.Finish)
              If .Shift2.Start <> 0 Then Str = Str & BuildString(.Shift2.Start, .Shift2.Finish)
              If .Shift3.Start <> 0 Then Str = Str & BuildString(.Shift3.Start, .Shift3.Finish)
              If .Shift4.Start <> 0 Then Str = Str & BuildString(.Shift4.Start, .Shift4.Finish)
              If .Shift5.Start <> 0 Then Str = Str & BuildString(.Shift5.Start, .Shift5.Finish)
              Get_Shifts = Str
         End With
End Function

Function BuildString(S As String, F As String) As String
         BuildString = ", " & Format(S, "hh:nn AM/PM") & " - " & Format(F, "hh:nn AM/PM")
End Function