我想看看是否有一个 VBA 宏，以便创建一封电子邮件，列出所有团队成员的会议可用性，这些会议可用性是使用与会者下的会议草稿中列出的团队成员共享的。如果有人很忙，则不应列出时间。基本上是从日程安排助理那里获取所有建议的时间。 格式如下：
10/21/24 上午 9 点至上午 10 点，下午 2:30 至下午 3 点
我使用了下面的代码，它用时间（格式错误）填充了一封电子邮件，例如
Suggested meeting times:
10/22/2024 (09:00 AM)
10/22/2024 (09:30 AM)
10/22/2024 (10:00 AM)
10/22/2024 (10:30 AM)
10/22/2024 (11:00 AM)
10/22/2024 (11:30 AM)
10/22/2024 (12:00 PM)
10/22/2024 (12:30 PM)
但是时间不正确，并非所有会员都在那段时间有空
Sub GetSharedFreeTimeWithStrictCheck()
Dim objNS As Outlook.NameSpace
Dim objAppt As Outlook.AppointmentItem
Dim objRecipient As Outlook.Recipient
Dim objAddressEntry As Outlook.AddressEntry
Dim objEmail As Outlook.mailItem
Dim strAvailability As String
Dim StartDate As Date
Dim EndDate As Date
Dim strFreeBusy As String
Dim recipientResolved As Boolean
Dim TimeSlotStart As Date
Dim TimeSlotEnd As Date
Dim slot As Integer
Dim commonFreeTimes() As Boolean
Dim actualSlots As Integer
Dim firstRun As Boolean
Dim WorkingHoursStart As Double
Dim WorkingHoursEnd As Double
Dim inFreeBlock As Boolean
Dim blockStart As Date
Dim currentDate As String
' Define the working hours (9 AM to 5 PM)
WorkingHoursStart = 9 / 24 ' 9 AM as a fraction of a day
WorkingHoursEnd = 17 / 24 ' 5 PM as a fraction of a day
' Ensure that the current item is a calendar invite (meeting request)
If TypeOf Application.ActiveInspector.CurrentItem Is Outlook.AppointmentItem Then
Set objAppt = Application.ActiveInspector.CurrentItem
Else
MsgBox "Please open a calendar invite (meeting request) to use this script."
Exit Sub
End If
' Set the date range (next 7 days, excluding weekends)
StartDate = Date
EndDate = Date + 7
' Set up Namespace to access Outlook data
Set objNS = Application.GetNamespace("MAPI")
' Flag to track if we are processing the first attendee
firstRun = True
' Loop through each recipient (attendee) in the calendar invite
For Each objRecipient In objAppt.Recipients
recipientResolved = False
On Error Resume Next
recipientResolved = objRecipient.Resolve
On Error GoTo 0
' If the recipient was resolved, get free/busy information
If recipientResolved Then
Set objAddressEntry = objRecipient.AddressEntry
' Get free/busy information for the next 7 days (in 30-minute intervals)
On Error Resume Next
strFreeBusy = objAddressEntry.GetFreeBusy(StartDate, 30, True)
On Error GoTo 0
' Determine the actual number of slots from the free/busy string length
actualSlots = Len(strFreeBusy)
' If we successfully retrieved the free/busy string, process it
If actualSlots > 0 Then
' Initialize the commonFreeTimes array if this is the first attendee
If firstRun Then
ReDim commonFreeTimes(1 To actualSlots)
For slot = 1 To actualSlots
commonFreeTimes(slot) = True ' Assume all slots are free initially
Next slot
firstRun = False ' Mark that the first run has completed
End If
' Process the current attendee's free/busy string, filtering by working hours
For slot = 1 To actualSlots
TimeSlotStart = StartDate + ((slot - 1) * (1 / 48)) ' Each slot is 30 minutes
' Only consider weekdays (exclude Saturday and Sunday)
If Weekday(TimeSlotStart, vbMonday) <= 5 Then
' Only consider slots between 9 AM and 5 PM
If TimeSlotStart - Int(TimeSlotStart) >= WorkingHoursStart And TimeSlotStart - Int(TimeSlotStart) < WorkingHoursEnd Then
' If this attendee is NOT free in this slot, mark it as busy (False)
If Mid(strFreeBusy, slot, 1) <> "0" Then
commonFreeTimes(slot) = False
End If
' Strict condition: if the current block or the next block has a meeting, this block is busy
If slot < actualSlots Then
If Mid(strFreeBusy, slot + 1, 1) <> "0" Then
commonFreeTimes(slot) = False ' Mark this slot as busy if the next slot is not free
End If
End If
End If
End If
Next slot
End If
End If
Next objRecipient
' Create a new email draft to display common availability
Set objEmail = Application.CreateItem(olMailItem)
objEmail.Subject = "Shared Free Time for All Attendees (9 AM to 5 PM, Weekdays Only)"
' Initialize the email body
strAvailability = "Shared free blocks (9 AM to 5 PM) for the next 7 days (excluding weekends):" & vbCrLf & vbCrLf
' Loop through the commonFreeTimes array and find slots where all attendees are free during working hours
inFreeBlock = False ' Track if we are inside a free time block
For slot = 1 To actualSlots
TimeSlotStart = StartDate + ((slot - 1) * (1 / 48)) ' Each slot is 30 minutes
' Only consider weekdays and slots between 9 AM and 5 PM
If Weekday(TimeSlotStart, vbMonday) <= 5 Then
If TimeSlotStart - Int(TimeSlotStart) >= WorkingHoursStart And TimeSlotStart - Int(TimeSlotStart) < WorkingHoursEnd Then
If commonFreeTimes(slot) Then
' If not already in a free block, start one
If Not inFreeBlock Then
blockStart = TimeSlotStart
inFreeBlock = True
currentDate = Format(blockStart, "mm/dd/yyyy")
End If
Else
' If we're in a free block but this slot isn't free, close the block
If inFreeBlock Then
TimeSlotEnd = TimeSlotStart ' End the block at the previous slot
strAvailability = strAvailability & "o " & currentDate & ": " & Format(blockStart, "hh:mm AMPM") & " - " & Format(TimeSlotEnd, "hh:mm AMPM") & vbCrLf
inFreeBlock = False
End If
End If
Else
' If we've hit the end of the working day, close the block
If inFreeBlock Then
TimeSlotEnd = Int(TimeSlotStart) + WorkingHoursEnd ' End the block at 5 PM
strAvailability = strAvailability & "o " & currentDate & ": " & Format(blockStart, "hh:mm AMPM") & " - " & Format(TimeSlotEnd, "hh:mm AMPM") & vbCrLf
inFreeBlock = False
End If
End If
End If
Next slot
' If we end the loop and are still inside a free block, close it at 5 PM
If inFreeBlock Then
TimeSlotEnd = Int(TimeSlotStart) + WorkingHoursEnd ' End the block at 5 PM of the last free slot day
strAvailability = strAvailability & "o " & currentDate & ": " & Format(blockStart, "hh:mm AMPM") & " - " & Format(TimeSlotEnd, "hh:mm AMPM") & vbCrLf
End If
' If no common free time slots were found
If Len(strAvailability) <= 100 Then
strAvailability = strAvailability & "No common free time slots found for all attendees during working hours (9 AM to 5 PM) on weekdays."
End If
' Set the email body to include the common availability information
objEmail.Body = strAvailability
' Display the email (you can use .Send to send it automatically)
objEmail.Display
' Clean up
Set objNS = Nothing
Set objAppt = Nothing
Set objEmail = Nothing
End Sub
这似乎对我有用 - 我进行了一些重构，以消除重复的工作并简化流程/减少嵌套级别。
备注：
Option Explicit
Sub GetSharedFreeTimeWithStrictCheck()
Const SlotMins As Long = 30
Dim olApp As Object, objNS As Object, objAppt As Object, objRecipient As Object
Dim StartDate As Date
Dim strFreeBusy As String
Dim actualSlots As Long
Dim firstRun As Boolean
Dim inFreeBlock As Boolean, goodSlots() As Double, commonFreeTimes() As Boolean
Dim blockStart As Date, sep As String
Dim currentDay As Date, slotDay, colFB As Collection, i As Long, fb, free As Boolean, s As String
Set olApp = GetObject(, "Outlook.application") 'I'm running this from Excel....
' Ensure that the current item is a calendar invite (meeting request)
Set objAppt = olApp.ActiveInspector.CurrentItem
If TypeName(objAppt) <> "AppointmentItem" Then Exit Sub
StartDate = Date
' Loop through each recipient (attendee) in the calendar invite and
' collect the freebusy info where available
Set colFB = New Collection
For Each objRecipient In objAppt.Recipients
strFreeBusy = RecipientFreeBusy(objRecipient, StartDate, SlotMins, True)
If Len(strFreeBusy) > 0 Then colFB.Add strFreeBusy
'what if not available?
Next objRecipient
If colFB.Count = 0 Then Exit Sub ' no free/busy info!
actualSlots = Len(colFB(1)) 'how many slots for each recipient?
ReDim commonFreeTimes(1 To actualSlots)
'get an array of all acceptable start times (or zero if not acceptable)
goodSlots = usableSlots(actualSlots, StartDate, SlotMins)
firstRun = True ' Flag to track if we are processing the first attendee
For Each fb In colFB ' check all returned busyFree
For i = 1 To actualSlots
If goodSlots(i) > 0 Then 'day/time is potentially OK?
free = (Mid(fb, i, 1) = "0")
If firstRun Then
commonFreeTimes(i) = free
Else
If Not free Then commonFreeTimes(i) = False
End If
End If
Next i
firstRun = False
Next fb
s = ""
currentDay = 0
inFreeBlock = False
'loop and list common free slots
For i = 1 To actualSlots
If commonFreeTimes(i) Then 'free ?
blockStart = goodSlots(i)
If Not inFreeBlock Then 'starting a new block?
slotDay = Int(blockStart) 'are we in a new day?
If slotDay <> currentDay Then
s = s & vbLf & Format(blockStart, "dd-mmm-yyyy") & ":"
currentDay = slotDay
sep = "" 'clear comma separator
End If
s = s & sep & " " & Format(blockStart, "hh:nnam/pm") & "-"
inFreeBlock = True
sep = "," 'add comma for next slot if any
End If
Else
If inFreeBlock Then
s = s & Format(goodSlots(i), "hh:nnam/pm")
inFreeBlock = False
End If
End If
Next i
'should never end this loop in a free block...
Debug.Print s '<<< put this in an email....
End Sub
'Try to resolve the recipient and get their FreeBusy info
Function RecipientFreeBusy(oRecip As Object, fromWhen, IntervalMins As Long, detailed As Boolean) As String
On Error Resume Next
If oRecip.Resolve Then
RecipientFreeBusy = oRecip.AddressEntry.GetFreeBusy(fromWhen, IntervalMins, detailed)
End If
End Function
'Fill an array of length `numSlots` with potential start times, beginning at `StartDate`
' and using an interval of `SlotMins`
'Acceptable start times are 9am to (5pm-SlotMins), Mon-Fri
Function usableSlots(numSlots As Long, StartDate, SlotMins As Long) As Double()
Const MinPerDay As Long = 1440
Dim WorkingHoursStart As Double, WorkingHoursEnd As Double
Dim i As Long, slotStart, rv() As Double, slotLen As Double
' Define the working hours (9 AM to 5 PM)
WorkingHoursStart = 9 / 24 ' 9 AM as a fraction of a day
WorkingHoursEnd = 17 / 24 ' 5 PM as a fraction of a day
slotLen = SlotMins / MinPerDay
ReDim rv(1 To numSlots)
For i = 1 To numSlots
slotStart = StartDate + (i - 1) * (1 / 48)
If Weekday(slotStart, vbMonday) <= 5 Then
If slotStart - Int(slotStart) >= WorkingHoursStart Then
If slotStart - Int(slotStart) <= (WorkingHoursEnd - slotLen) Then
rv(i) = slotStart 'populate the slot start
End If
End If
End If
Next i
usableSlots = rv
End Function