|OLKeeper reliably prevents users from closing their Outlook window and thus possibly missing reminders or e-mails.|
If you need to block necessary travel time for a meeting, or for the time you need to prepare for the meeting, you either need to add up to two additional appointments to your calendar, or extend the main appointment accordingly.
This macro adds up to two additional appointments for each selected appointment to your calendar: One before, and one after the main appointment. The commented lines show where you can easily customize the code:
Paste the code to the ThisOutlookSession module. Then select any appointments in your calendar, and press ALT+F8 to run the macro.
Public Sub AddTravelTime() 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 = 30 After = 30 '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 = "Travel" 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 = 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 = 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
|ReplyAll alerts you before unintentionally replying all, or if you are a confidential BCC recipient of the e-mail.|