Reisezeit für Termine blockieren

Zu einem Termin gehören häufig An- und Abreisezeiten oder Zeiten, die Sie zur Vor- und Nachbereitung benötigen. Wenn Sie diese Zeiten im Kalender sichtbar machen wollen, müssen Sie entweder bis zu drei Termine eintragen oder den eigentlichen Termin entsprechend ausdehnen.

Dieses Makro trägt für ausgewählte Termine bis zu zwei weitere in den Kalender ein: Einen vor dem eigentlichen Termin und einen danach. Die kommentierten Zeilen zeigen Ihnen, wo Sie die Vorgaben anpassen können:

1. In den Variablen Before und After steht die Dauer der beiden Termine in Minuten. Die Standardwerte sind hier auf jeweils 30 Minuten festgelegt.
2. Danach erfolgt eine Abfrage der beiden Zeiten. Wenn die zu verwendenden Zeiten immer gleich sind, können Sie die beiden Abfragen auskommentieren.
3. Den Terminen wird eine Kategorie zugewiesen. So können Sie die farblich von den Hauptterminen abheben. Ersetzen Sie hier Reisezeit bei Bedarf durch einen anderen Namen.
4. Als Betreff wird der des Haupttermins verwendet. Hier können Sie auch einen anderen Namen verwenden (Text muss in Anführungszeichen eingeschlossen werden).

Kopieren Sie das Makro ins Modul DieseOutlookSitzung. Markieren Sie dann beliebig viele Termine im Kalender und drücken Sie ALT+F8, um das Makro zu starten.

  So fügen Sie Makros in Outlook ein

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. Folgende Minuten vor- und nachher blocken
  Before = 30
  After = 30

  '2. Auskommentieren, wenn die Werte immer gleich sind
  Before = InputBox("Minutes before:", , Before)
  After = InputBox("Minutes after:", , After)

  If Before = 0 And After = 0 Then Exit Sub

  '3. Diese Kategorie eintragen
  Category = "Reisezeit"

  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