Aktionen mit Kategorien auslösen

Alle Emails in einen Unterordner verschieben

Das erste Beispiel verschiebt eine Email in einen bestimmten Unterordner des Posteingangs, sobald Sie der Email eine festgelegte Kategorie zuweisen. Wenn der Email weitere Kategorien zugewiesen sind, werden die ignoriert. Passen Sie einfach die beiden Variablen in der Mail_PropertyChange-Prozedur an (die zu suchende Kategorie und der Name des Unterordners).

Das eigentliche Verschieben kann nicht direkt in der PropertyChange-Prozedur stattfinden, deswegen wird ein Timer gestartet, um das Verschieben vom PropertyChange zu entkoppeln.

Hier finden Sie den Code für den API-Timer.

  So fügen Sie Makros in Outlook ein

Private WithEvents Explorer As Outlook.Explorer
Private WithEvents Mail As Outlook.MailItem
Private MoveToThisFolder As Outlook.MapiFolder

Friend Sub Application_Startup()
  On Error Resume Next
  Set Explorer = Application.ActiveExplorer
End Sub

Private Sub Explorer_SelectionChange()
  Dim obj As Object
  Dim Sel As Outlook.Selection

  Set Mail = Nothing
  Set Sel = Explorer.Selection

  If Sel.Count > 0 Then
    Set obj = Sel(1)
    If TypeOf obj Is Outlook.MailItem Then
      Set Mail = obj
    End If
  End If
End Sub

Private Sub Mail_PropertyChange(ByVal Name As String)
  Dim Ns As Outlook.NameSpace
  Dim SubfolderName As String
  Dim Inbox As Outlook.MAPIFolder
  Dim Subfolder As Outlook.MAPIFolder
  Dim i&
  Dim Cats As String
  Dim arrCats() As String
  Dim FindCategory As String

  'Anpassen: Tragen Sie hier den Namen der zu suchenden Kategorie ein
  FindCategory = " (Actionlist)"
  'Tragen Sie hier den Namen des Ordners ein
  SubfolderName = "test"

  Set Ns = Application.GetNamespace("MAPI")
  Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
  Set Subfolder = Inbox.Folders(SubfolderName)
  If Subfolder.EntryID = Mail.Parent.EntryID Then
    Exit Sub
  End If

  If Name = "Categories" Then
    Cats = LCase$(Mail.Categories)
    FindCategory = LCase$(FindCategory)
    If Len(Cats) = 0 Then Exit Sub
    Cats = Replace(Cats, ",", ";")
    arrCats = Split(Cats, ";")
    For i = 0 To UBound(arrCats)
      Cats = Trim$(arrCats(i))
      If Cats = FindCategory Then
        Set MoveToThisFolder = Subfolder
        EnableTimer 500, Me
        Exit For
      End If
    Next
  End If
End Sub

Friend Sub TimerEvent()
  DisableTimer
  If Mail Is Nothing Then Exit Sub
  If MoveToThisFolder Is Nothing Then Exit Sub
  Mail.Move MoveToThisFolder
  Set Mail = Nothing
  Set MoveToThisFolder = Nothing
End Sub

Verschieben in den Ordner mit dem Kategorienamen

Das zweite Beispiel verschiebt die Email in einen Unterordner des Posteingangs, der genauso heisst, wie die zugewiesene Kategorie. Auch hier wird das eigentliche Verschieben erst durch einen Timer angestoßen.

Hier finden Sie den Code für den API-Timer.

Private WithEvents Explorer As Outlook.Explorer
Private WithEvents Mail As Outlook.MailItem
Private MoveToThisFolder As Outlook.MapiFolder

Friend Sub Application_Startup()
  On Error Resume Next
  Set Explorer = Application.ActiveExplorer
End Sub

Private Sub Explorer_SelectionChange()
  Dim obj As Object
  Dim Sel As Outlook.Selection

  Set Mail = Nothing
  Set Sel = Explorer.Selection

  If Sel.Count > 0 Then
    Set obj = Sel(1)
    If TypeOf obj Is Outlook.MailItem Then
      Set Mail = obj
    End If
  End If
End Sub

Private Sub Mail_PropertyChange(ByVal Name As String)
  Dim Ns As Outlook.NameSpace
  Dim Inbox As Outlook.MAPIFolder
  Dim Subfolder As Outlook.MAPIFolder
  Dim SubfolderName As String

  If Name = "Categories" Then
    Set Ns = Application.GetNamespace("MAPI")
    Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
    SubfolderName = Mail.Categories
    If Len(SubfolderName) = 0 Then Exit Sub
    Set Subfolder = Inbox.Folders(SubfolderName)
    If Subfolder.EntryID <> Mail.Parent.EntryID Then
      Set MoveToThisFolder = Subfolder
      EnableTimer 500, Me
    End If
  End If
End Sub

Friend Sub TimerEvent()
  DisableTimer
  If Mail Is Nothing Then Exit Sub
  If MoveToThisFolder Is Nothing Then Exit Sub
  Mail.Move MoveToThisFolder
  Set Mail = Nothing
  Set MoveToThisFolder = Nothing
End Sub

Den Regelassistenten starten

Dieses Beispiel führt alle aktiven Regeln aus, die Sie über den Regel-Assistenten erstellt haben, wenn Sie einer Email die Kategorie '(ActionList)' zuweisen.

Dieses Beispiel geht erst ab Outlook 2007.

Private WithEvents Explorer As Outlook.Explorer
Private WithEvents Mail As Outlook.MailItem
Private MoveToThisFolder As Outlook.MapiFolder

Friend Sub Application_Startup()
  On Error Resume Next
  Set Explorer = Application.ActiveExplorer
End Sub

Private Sub Explorer_SelectionChange()
  Dim obj As Object
  Dim Sel As Outlook.Selection

  Set Mail = Nothing
  Set Sel = Explorer.Selection

  If Sel.Count > 0 Then
    Set obj = Sel(1)
    If TypeOf obj Is Outlook.MailItem Then
      Set Mail = obj
    End If
  End If
End Sub

Private Sub Mail_PropertyChange(ByVal Name As String)
  Dim CurrentFolder As Outlook.Folder
  Dim CurrentStore As Outlook.Store
  Dim Rules As Outlook.Rules
  Dim Rule As Outlook.Rule
  Dim i&
  Dim Cats As String
  Dim arrCats() As String
  Dim FindCategory As String
  Dim RunRules As Boolean

  'Anpassen: Tragen Sie hier den Namen der zu suchenden Kategorie ein
  FindCategory = "(Actionlist)"

  If Name = "Categories" Then
    Cats = LCase$(Mail.Categories)
    FindCategory = LCase$(FindCategory)
    If Len(Cats) = 0 Then Exit Sub
    Cats = Replace(Cats, ",", ";")
    arrCats = Split(Cats, ";")
    For i = 0 To UBound(arrCats)
      Cats = Trim$(arrCats(i))
      If Cats = FindCategory Then
        Set Mail = Nothing
        RunRules = True
        Exit For
      End If
    Next
  End If

  If RunRules Then
    Set CurrentFolder = Application.ActiveExplorer.CurrentFolder
    Set CurrentStore = CurrentFolder.Store
    Set Rules = CurrentStore.GetRules
    For Each Rule In Rules
      If Rule.Enabled Then
        Rule.Execute
      End If
    Next
  End If
End Sub

Termin als privat markieren

Mit diesem Code werden alle Termine, denen Sie eine bestimmte Kategorie zuweisen, gleichzeitig als privat markiert. Passen Sie in der PropertyChange-Prozedur den Kategorienamen (derzeit '(Actionlist)') an.

Private WithEvents Explorer As Outlook.Explorer
Private WithEvents Appointment As Outlook.AppointmentItem

Friend Sub Application_Startup()
  Set Explorer = Application.ActiveExplorer
End Sub

Private Sub Explorer_SelectionChange()
  Dim obj As Object
  Dim Sel As Outlook.Selection

  Set Appointment = Nothing
  Set Sel = Explorer.Selection

  If Sel.Count > 0 Then
    Set obj = Sel(1)
    If TypeOf obj Is Outlook.AppointmentItem Then
      Set Appointment = obj
    End If
  End If
End Sub

Private Sub Appointment_PropertyChange(ByVal Name As String)
  Dim i&
  Dim Cats As String
  Dim arrCats() As String
  Dim FindCategory As String
  Dim RunRules As Boolean

  'Anpassen: Tragen Sie hier den Namen der zu suchenden Kategorie ein
  FindCategory = "(Actionlist)"

  If Name = "Categories" Then
    Cats = LCase$(Appointment.Categories)
    If Len(Cats) = 0 Then Exit Sub
    FindCategory = LCase$(FindCategory)
    Cats = Replace(Cats, ",", ";")
    arrCats = Split(Cats, ";")
    For i = 0 To UBound(arrCats)
      Cats = Trim$(arrCats(i))
      If Cats = FindCategory Then
        RunRules = True
        Exit For
      End If
    Next
  End If

  If RunRules Then
    Appointment.Sensitivity = olPrivate
    Appointment.Save
  End If
End Sub