When you're in a business environment, you most likely have to use Outlook for managing meetings. A common problem is that you've got a meeting scheduled with a couple of peers and you need some time extra. For example, you have to walk to a different building or you just want some preparation time, you need a time slot upfront and/or directly after the meeting.
In order to avoid beeing booked for a different meeting which adjoins the other one, you need to manually create appointments before and/or after the meeting. The other option is that your calendar shows a free time where there isn't one. Unfortunately, people avoid this tedious task and therefore, this situation is common practice.
I do have an elegant solution for this issue: an easy-to-reach button which adds appointment before and/or after a selected appointment.
To my great surprise, I found a ready-to use solution online.
You just need to press
Alt-F11, paste the following script into your VBA-editor, and add a Quick Access Toolbar item to your Outlook. In case you need further help with the setup, please take a look at the screen-shots on my blog entry where I describe how I keep appointments on my calendar without accepting or declining them.
Public Sub AddPreparationAndPostprocessingTime() Dim coll As VBA.Collection Dim obj As Object Dim Appt As Outlook.AppointmentItem Dim Travel As Outlook.AppointmentItem Dim Items As Outlook.Items Dim Before&, After& Dim Category$, Subject$ '1. Block minutes before and after the appointment Before = 15 After = 0 '2. Skip this if the default values never change Before = InputBox("Minutes before:", , Before) After = InputBox("Minutes after:", , After) If Before = 0 And After = 0 Then Exit Sub '3. Assign this category Category = "Gelbe Kategorie" 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 '4. Use the main appointment's subject Subject = Appt.Subject If Before > 0 Then Set Travel = Items.Add Travel.Subject = "Preparation for: " + Subject Travel.Start = DateAdd("n", -Before, Appt.Start) Travel.Duration = Before Travel.Categories = Category Travel.Save End If If After > 0 Then Set Travel = Items.Add Travel.Subject = "Postprocessing: " + Subject Travel.Start = Appt.End Travel.Duration = After Travel.Categories = Category Travel.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