I'm trying to find a way to automatically add a 30 minute appointment after every meeting I accept. I found the below code on the web, but it requires you to go into your calendar, select the meeting, then manually run the macro.
My thought was that I could add a custom button to the toolbar that acted as the "Accept" button and then schedule the 30 minute follow-up meeting.
Any thoughts/assistance would be very much appreciated.
Code:
Public Sub AddBreakTime()
Dim coll As VBA.Collection
Dim obj As Object
Dim Appt As Outlook.AppointmentItem
Dim FreeTime As Outlook.AppointmentItem
Dim Items As Outlook.Items
Dim Before&, After&
Dim Category$, Subject$
'1. Block minutes before and after the appointment
Before = 30
After = 30
If Before = 0 And After = 0 Then Exit Sub
Set coll = GetCurrentItems
If coll.Count = 0 Then Exit Sub
For Each obj In coll
If TypeOf obj Is Outlook.AppointmentItem Then
Set Appt = obj
If TypeOf Appt.Parent Is Outlook.AppointmentItem Then
Set Items = Appt.Parent.Parent.Items
Else
Set Items = Appt.Parent.Items
End If
If Before > 0 Then
Set FreeTime = Items.Add
FreeTime.Subject = "Free Time"
FreeTime.Start = DateAdd("n", -Before, Appt.Start)
FreeTime.Duration = Before
FreeTime.Save
End If
If After > 0 Then
Set FreeTime = Items.Add
FreeTime.Subject = "Free Time"
FreeTime.Start = Appt.End
FreeTime.Duration = After
FreeTime.Save
End If
End If
Next
End Sub
Private Function GetCurrentItems(Optional IsInspector As Boolean) As VBA.Collection
Dim coll As VBA.Collection
Dim Win As Object
Dim Sel As Outlook.Selection
Dim obj As Object
Dim i&
Set coll = New VBA.Collection
Set Win = Application.ActiveWindow
If TypeOf Win Is Outlook.Inspector Then
IsInspector = True
coll.Add Win.CurrentItem
Else
IsInspector = False
Set Sel = Win.Selection
If Not Sel Is Nothing Then
For i = 1 To Sel.Count
coll.Add Sel(i)
Next
End If
End If
Set GetCurrentItems = coll
End Function