Outlook Consolidate Availability for CC and FROM addresses into fixed width table

User Availability

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "UserAvailability"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' Class Module: UserAvailability
Option Explicit

Private pEmail As String
Private pTimeZone As Outlook.TimeZone 'As String
Private pDays As Collection
'Private pWorkdayStart As Date          ''Currently NO WAY to get work day start or end...Guess with busy/free
'Private pWorkdayEnd As Date

'Public Property Get WorkdayStart() As Date
'    WorkdayStart = pWorkdayStart
'End Property
'
'Public Property Let WorkdayStart(Value As Date)
'    pWorkdayStart = Value
'End Property
'
'Public Property Get WorkdayEnd() As Date
'    WorkdayEnd = pWorkdayEnd
'End Property
'
'Public Property Let WorkdayEnd(Value As Date)
'    pWorkdayEnd = Value
'End Property


Public Property Get Email() As String
    Email = pEmail
End Property

Public Property Let Email(Value As String)
    pEmail = Value
End Property

Public Property Get TimeZone() As Outlook.TimeZone
    TimeZone = pTimeZone
End Property

Public Property Let TimeZone(Value As Outlook.TimeZone)
    pTimeZone = Value
End Property

Public Property Get Days() As Collection
    Set Days = pDays
End Property

Public Sub InitializeDays(StartDate As Date, EndDate As Date)
    Dim d As Date
    Set pDays = New Collection
    For d = StartDate To EndDate
        Dim dayAvail As DayAvailability
        Set dayAvail = New DayAvailability
        dayAvail.DateValue = d ' Use DateValue instead of Date
        dayAvail.InitializeSlots
        pDays.Add dayAvail
    Next d
End Sub


Quarter Hour Slots
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "QuarterHourSlot"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
' Class Module: QuarterHourSlot
Private pStatus As String * 1

Public Property Get Status() As String
    Status = pStatus
End Property

Public Property Let Status(Value As String)
    pStatus = Value
End Property

Daily Availability
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "DayAvailability"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' Class Module: DayAvailability
Option Explicit

Private pDateValue As Date
Private pSlots() As QuarterHourSlot

Public Property Get DateValue() As Date
    DateValue = pDateValue
End Property

Public Property Let DateValue(Value As Date)
    pDateValue = Value
End Property

Public Sub InitializeSlots()
    Dim i As Integer
    ReDim pSlots(0 To 95) ' 96 quarter-hour slots in a day
    For i = 0 To 95
        Set pSlots(i) = New QuarterHourSlot
        pSlots(i).Status = "*" ' Default status
    Next i
End Sub

Public Property Get Slot(ByVal Index As Integer) As QuarterHourSlot
    Set Slot = pSlots(Index)
End Property


Main Module otlCalendar

Attribute VB_Name = "otlCalendarv5_Classes_FreeBusy"
Option Explicit
' In a standard module
Type TimeZoneInfo
    Code As String
    Offset As Integer
End Type
''-------------------------------------------------------------
Sub AAAA_GetUserAndCC_Availability()
    Dim OutlookApp As Outlook.Application
    Dim Namespace As Outlook.Namespace
    Dim Recipient As Outlook.Recipient
    Dim StartDate As Date, EndDate As Date
    Dim CurrentMail As Outlook.MailItem
    Dim CurrentUser As Outlook.AddressEntry
    Dim CurrentUserEmail As String
    Dim AllEmails As String
    Dim UserEmails() As String
    Dim UserCount As Integer
    Dim i As Integer
    Dim Users As Collection
    Dim UserTimeZones() As String
    Dim UserWorkStart() As Date
    Dim UserWorkEnd() As Date
    Dim elapsed As Date
    elapsed = Date + Time
   
    ' Initialize Outlook application
    Set OutlookApp = New Outlook.Application
    Set Namespace = OutlookApp.GetNamespace("MAPI")

    ' Define the time range to check for availability
    StartDate = Now
    EndDate = DateAdd("d", 7, StartDate)

    ' Get the current active email
    On Error Resume Next
    Set CurrentMail = OutlookApp.ActiveInspector.CurrentItem
    On Error GoTo 0

    If CurrentMail Is Nothing Or CurrentMail.cc = "" Then
        MsgBox "Please open an email with CC's to search for the calendar openings.", vbExclamation
        Exit Sub
    End If

    ' Get the current user's email
    Set CurrentUser = OutlookApp.Session.CurrentUser.AddressEntry
    CurrentUserEmail = GetSMTPAddress_From_AddressEntry(CurrentUser)

    ' Get email addresses from the CC field
    Dim otlAddr As Recipient
    Dim ccRecipients As String
    ccRecipients = ""
    For Each otlAddr In CurrentMail.Recipients
        If otlAddr.Type = olCC Then
            ccRecipients = ccRecipients & GetSMTPAddress_From_AddressEntry(otlAddr.AddressEntry) & ";"
        End If
    Next otlAddr

    ' Check if there are no CC recipients
    If Len(ccRecipients) = 0 Then
        MsgBox "No CC recipients found. Please ensure there are CC recipients in the email.", vbExclamation
        Exit Sub
    End If

    ' Combine CC recipients and current user's email
    AllEmails = ccRecipients & CurrentUserEmail

    ' Split the combined string into a String array
    UserEmails = Split(AllEmails, ";")
    UserCount = UBound(UserEmails) + 1

    ' Initialize collection for users
    Set Users = New Collection
    'ReDim UserTimeZones(1 To UserCount)
    'ReDim UserWorkStart(1 To UserCount)
    'ReDim UserWorkEnd(1 To UserCount)

    ' Populate user data
    For i = 1 To UserCount
        Dim userAvail As UserAvailability
        Set userAvail = New UserAvailability
        With userAvail
            .Email = Trim(UserEmails(i - 1))
            .InitializeDays StartDate, EndDate
        End With
        Users.Add userAvail

        ' Resolve recipient and get free/busy data
        Set Recipient = Namespace.CreateRecipient(userAvail.Email)
        If Recipient.Resolve Then
            ' Get user working hours and time zone from free/busy information
            ''Call GetUserWorkingHoursFromFreeBusy(Recipient, UserWorkStart(i), UserWorkEnd(i), UserTimeZones(i))
           
            With userAvail
                .TimeZone = Recipient.Application.TimeZones.CurrentTimeZone ''<<<DEBUG PROBABLY NOT CORRECT...
                '.WorkdayStart = UserWorkStart(i)
                '.WorkdayEnd = UserWorkEnd(i)
            End With
           
            ' Populate user's availability
            Call PopulateUserAvailability(userAvail, Namespace.GetSharedDefaultFolder(Recipient, olFolderCalendar).Items, StartDate, EndDate)
        Else
            MsgBox "Outlook does not recognize the name: " & userAvail.Email, vbExclamation
        End If
    Next i

    ' Adjust user availability for work hours
    AdjustUsersForWorkHours Users, UserWorkStart, UserWorkEnd

    ' Display the availability matrix
    DisplayUserAvailability Users
   
    Debug.Print ((Date + Time) - elapsed) * 24 * 60 * 60
End Sub
''-------------------------------------------------------------

Private Sub GetUserWorkingHoursFromFreeBusy(Recipient As Outlook.Recipient, ByRef WorkStart As Date, ByRef WorkEnd As Date, ByRef TimeZone As Outlook.TimeZone)
    Dim ns As Outlook.Namespace
    Dim FreeBusyInfo As String
    Dim i As Integer
    Dim busySlots As Integer
    Dim currentHour As Date
   
    ' Default working hours and time zone
    WorkStart = TimeValue("09:00 AM")
    WorkEnd = TimeValue("05:00 PM")
    TimeZone = Application.TimeZones.Item(0)
   
    ' Get the current session's namespace
    Set ns = Application.GetNamespace("MAPI")
   
    ' Get the free/busy information for the recipient
    FreeBusyInfo = Recipient.FreeBusy(Start:=Now, MinPerChar:=60, CompleteFormat:=True)
   
    ' Analyze free/busy info to determine typical working hours
    busySlots = 0
    currentHour = TimeValue("12:00 AM")
    For i = 1 To Len(FreeBusyInfo)
        If Mid(FreeBusyInfo, i, 1) <> "0" Then
            busySlots = busySlots + 1
            If busySlots = 1 Then
                WorkStart = currentHour
            End If
            WorkEnd = currentHour + TimeSerial(1, 0, 0)
        End If
        currentHour = currentHour + TimeSerial(1, 0, 0)
    Next i
    ' Assuming UTC for simplicity. You might need to adjust this to match your organization's settings.
    TimeZone = Recipient.Application.TimeZones.CurrentTimeZone.name ''"UTC"
End Sub

Private Sub PopulateUserAvailability(user As UserAvailability, CalendarItems As Outlook.Items, ByVal StartDate As Date, ByVal EndDate As Date)
    Dim CalendarItem As Outlook.AppointmentItem
    Dim SlotStart As Date, SlotEnd As Date
    Dim Interval As Date
    Dim TotalDays As Long
    Dim DayIndex As Long
    Dim SlotIndex As Long

    TotalDays = EndDate - StartDate
    Interval = 15 / 1440 ' 15 minutes interval

    ' Mark slots with busy statuses
    For Each CalendarItem In CalendarItems
        SlotStart = CalendarItem.Start
        SlotEnd = CalendarItem.End

        If SlotStart < StartDate Then SlotStart = StartDate
        If SlotEnd > EndDate Then SlotEnd = EndDate

        Do While SlotStart < SlotEnd
            DayIndex = SlotStart - StartDate + 1
            SlotIndex = (SlotStart - Int(SlotStart)) * 24 * 4
            If DayIndex >= 1 And DayIndex <= TotalDays Then
                If SlotIndex >= 0 And SlotIndex < 96 Then
                    If CalendarItem.BusyStatus = olBusy Then
                        user.Days(DayIndex).Slot(SlotIndex).Status = "U"
                    ElseIf CalendarItem.BusyStatus = olTentative Then
                        user.Days(DayIndex).Slot(SlotIndex).Status = "T"
                    ElseIf CalendarItem.BusyStatus = olOutOfOffice Then
                        user.Days(DayIndex).Slot(SlotIndex).Status = "O"
                    ElseIf CalendarItem.BusyStatus = olWorkingElsewhere Then
                        user.Days(DayIndex).Slot(SlotIndex).Status = "W"
                    Else
                        user.Days(DayIndex).Slot(SlotIndex).Status = "*"
                    End If
                End If
            End If
            SlotStart = SlotStart + Interval
        Loop
    Next CalendarItem
End Sub

Private Sub AdjustUsersForWorkHours(Users As Collection, ByRef UserWorkStart() As Date, ByRef UserWorkEnd() As Date)
    Dim EarliestStart As Date
    Dim LatestEnd As Date
    Dim user As UserAvailability
    Dim Day As DayAvailability
    Dim SlotIndex As Long

    EarliestStart = TimeValue("07:00:00")
    LatestEnd = TimeValue("18:00:00")

    ' Determine the earliest start and latest end times
    Dim i As Long
    'For i = 1 To Users.Count
    '    If UserWorkStart(i) < EarliestStart Then EarliestStart = UserWorkStart(i) ''Cannot retrieve user start/end workday info
    '    If UserWorkEnd(i) > LatestEnd Then LatestEnd = UserWorkEnd(i)
    'Next i

    ' Adjust each user's day availability to exclude times outside all users' work hours
    For Each user In Users
        For Each Day In user.Days
            Dim StartSlot As Long
            Dim EndSlot As Long

            StartSlot = (EarliestStart - Int(EarliestStart)) * 24 * 4
            EndSlot = (LatestEnd - Int(LatestEnd)) * 24 * 4

            For SlotIndex = 0 To 95
                If SlotIndex < StartSlot Or SlotIndex >= EndSlot Then
                    Day.Slot(SlotIndex).Status = "x"
                End If
            Next SlotIndex
        Next Day
    Next user
End Sub
''---------------------------------------------------------------------
Private Sub DisplayUserAvailability(Users As Collection)
    Dim Output As String
    Dim user As UserAvailability
    Dim Day As DayAvailability
    Dim SlotIndex As Long
    Dim longest As Integer
    Dim StartDate As Date
    Dim TotalDays As Long
    Dim i As Long
    Dim TimeZones(0 To 4) As TimeZoneInfo
    Dim tzIndex As Integer
    Dim tzOffset As Integer
    Dim ND As Integer       ' Next day offset
    Dim curTZ As Integer    ''current timezone relative offset till we get the timezones sorted out....

    ' Time zones and their offsets from UTC
    TimeZones(0).Code = "UTC": TimeZones(0).Offset = 0
    TimeZones(1).Code = "EST": TimeZones(1).Offset = -5
    TimeZones(2).Code = "CST": TimeZones(2).Offset = -6
    TimeZones(3).Code = "MST": TimeZones(3).Offset = -7
    TimeZones(4).Code = "PST": TimeZones(4).Offset = -8

    ' Find the longest email length
    For Each user In Users
        If Len(user.Email) > longest Then longest = Len(user.Email)
    Next user

    If longest < 15 Then longest = 15 ' Ensure minimum length for UTC label

    ' Get the start date and total number of days from the first user (assuming all users have the same date range)
    StartDate = Users(1).Days(1).DateValue
    TotalDays = Users(1).Days.Count
   
    Dim strTZ As String, t As String
    strTZ = Application.TimeZones.CurrentTimeZone.name
    t = Mid(strTZ, 6, 5)
    curTZ = CInt(TimeValue(t) * 24)
    If Mid(strTZ, 5, 1) = "-" Then
        curTZ = -curTZ
    End If

    ' Generate time header for different time zones
    For tzIndex = LBound(TimeZones) To UBound(TimeZones)
        Output = Output & Right(String(longest, " ") & "TimeOfDay " & TimeZones(tzIndex).Code & ": ", longest + 2)
        tzOffset = TimeZones(tzIndex).Offset ' Adjust for timezone offsets
        If tzOffset - curTZ < 0 Then tzOffset = tzOffset + 24
        ' Loop through 24 hours in a day
        For SlotIndex = tzOffset - curTZ To tzOffset - curTZ + 23       ''one day
            ' Calculate the adjusted hour considering the timezone offset
            Dim adjustedHour As Integer
            adjustedHour = (SlotIndex) Mod 24
            Output = Output & Format(adjustedHour, "00") & "-- "
        Next SlotIndex
        Output = Output & vbCrLf
    Next tzIndex

    ' Print each user's availability
    For Each user In Users
        Output = Output & Right(String(longest, " ") & user.Email, longest) & vbCrLf
        For i = 1 To TotalDays
            Set Day = user.Days(i)
            Output = Output & Right(String(longest, " ") & Format(Day.DateValue, "yyyy-mm-dd"), longest) & ": "
            For SlotIndex = 0 To 95
                Select Case SlotIndex Mod 4
                    Case 3  ''last before next hour - add space
                        Output = Output & LCase(Day.Slot(SlotIndex).Status) & " "              ''add space on hour
                    Case 0  ''new hour
                        Output = Output & UCase(Day.Slot(SlotIndex).Status)
                    Case Else ''any other quarter hour
                        Output = Output & LCase(Day.Slot(SlotIndex).Status)
                End Select
            Next SlotIndex
            Output = Output & vbCrLf
        Next i
    Next user

    Debug.Print Output
End Sub