Emailadresse des Empfängers anzeigen

In der Ordneransicht zeigt Outlook nicht die E-Mail Adressen, sondern die Anzeigenamen. Diese Anzeigenamen sind oft sehr unterschiedlich, sogar für den gleichen Empfänger werden hier häufig unterschiedliche Werte angzeigt, so dass eine Sortierung oder Gruppierung nicht sinnvoll möglich ist.

Dieses Makro erstellt ein neues Feld im Ordner für gesendete Objekte und für den Posteingang und schreibt die reinen E-Mail-Adressen hinein. Für den Ordner Gesendete Objekte wird das Feld wird nicht als reines Textfeld, sondern als Keyword-Feld erstellt. Der Vorteil ist, dass Sie danach genauso gruppieren können wie nach den Kategorien. Die neuen Feldnamen sind 'EmpfängerAdressen' für gesendete Objekte und 'AbsenderAdresse' für den Posteingang.

Kopieren Sie den Code ins Modul DieseOulookSitzung und starten Sie Outlook dann neu. Nach dem nächsten Senden bzw. Erhalt einer Email gibt es das neue Feld in dem Ordner. Um das Feld dann im Ordner sichtbar zu machen, müssen Sie die aktuelle Ordneransicht anpassen und aus der Liste der anzuzeigenden Felder das neue Feld auswählen. Wechseln Sie dafür von 'Häufig verwendete Felder' zu 'Benutzerdefinierte Ordnerfelder'. (Wenn Sie das Feld auch den Emails hinzufügen wollen, die bereits im Ordner sind, verschieben Sie die Emails in einen anderen Ordner und wieder zurück.)

  So fügen Sie Makros in Outlook ein

Private WithEvents m_Inbox As Outlook.Items
Private WithEvents m_SentItems As Outlook.Items

Friend Sub Application_Startup()
  Dim Session As Outlook.NameSpace
  Set Session = Application.Session
  
  Set m_Inbox = Session.GetDefaultFolder(olFolderInbox).Items
  Set m_SentItems = Session.GetDefaultFolder(olFolderSentMail).Items
End Sub

Private Sub m_Inbox_ItemAdd(ByVal Item As Object)
  AddAddresses Item, False
End Sub

Private Sub m_SentItems_ItemAdd(ByVal Item As Object)
  AddAddresses Item, True
End Sub

Private Sub AddAddresses(Item As Object, ByVal IsSentMail As Boolean)
  Dim Recipients As Outlook.Recipients
  Dim R As Outlook.Recipient
  Dim UserProps As Outlook.UserProperties
  Dim Prop As Outlook.UserProperty
  Dim Adr As String
  Dim FieldName As String
  
  If IsSentMail Then
    FieldName = "EmpfängerAdressen"
    Set Recipients = Item.Recipients
    For Each R In Recipients
      Adr = Adr & R.Address & "; "
    Next
    If Len(Adr) Then
      Adr = Left$(Adr, Len(Adr) - 2)
    End If
  Else
    FieldName = "AbsenderAdresse"
    Adr = Item.SenderEmailAddress
  End If
  
  If Len(Adr) Then
    Set UserProps = Item.UserProperties
    Set Prop = UserProps.Find(FieldName, True)
    If Prop Is Nothing Then
      If IsSentMail Then
        Set Prop = UserProps.Add(FieldName, olKeywords, True)
      Else
        Set Prop = UserProps.Add(FieldName, olText, True)
      End If
    End If
    Prop.Value = Adr
    Item.Save
  End If
End Sub