Emailadressen vorschlagen

Wenn Sie in das Adressfeld (An, CC, BCC) einer Email Buchstaben eingeben, dann schlägt Outlook Adressen vor, die Sie schon mal verwendet haben. Dabei sucht Outlook die eingegebenen Zeichen aber nur am Anfang der Adresse. Geben Sie z.B 'vboffice' ein, findet Outlook 'vboffice@domain' aber nicht 'name@vboffice'.

Das folgende Makro sucht einen Begriff innerhalb aller Emailadressen aus Ihrem Standard-Kontakteordner. Dabei ist es egal, an welcher Stelle der Adresse sich der Begriff befindet. Starten Sie das Makro z.B. über ALT+F8. Wenn Sie das Makro aus einer bereits geöffneten Email heraus starten, werden die ausgewählten Adressen in die Email eingetragen, ansonsten wird eine neue Email erstellt.

Um das Beispiel einfach zu halten, werden die gefundenen Adressen in einer MsgBox angezeigt. Sie könnten den Code aber z.B. auch in einer eigenen MSForm verwenden und die Adressen in einer Listbox anzeigen.

Damit der Code funktioniert, müssen Sie die Redemption installieren, die für den Privatgebrauch kostenlos ist. Setzen Sie nach der Installation über Extras/Verweise einen Verweis auf die Redemption * Library.

  So fügen Sie Makros in Outlook ein

Public Sub SuggestAddresses()
  Dim Session As Redemption.RDOSession
  Dim Folder As Redemption.RDOFolder
  Dim Items As Redemption.RDOItems
  Dim Filter As Redemption.TableFilter
  Dim ResContent As Redemption.RestrictionContent
  Dim ResOr As Redemption.RestrictionOr
  Dim Item As Redemption.RDOContactItem
  Dim CollAdr As VBA.Collection
  Dim obj As Object
  Dim Mail As Outlook.MailItem
  Dim Email1 As Long, Email2 As Long, Email3 As Long
  Dim i As Long, Index As Long
  Dim AdrType As Long
  Dim IsNewMail As Boolean
  Dim FindString As String
  Dim Adr As String, Msg As String
  Dim UseAdr() As String
  
  FindString = InputBox("Suchbegriff:")
  If Len(FindString) = 0 Then Exit Sub
  
  Set Session = CreateObject("redemption.rdosession")
  Session.MAPIOBJECT = Application.Session.MAPIOBJECT
  Set Folder = Session.GetDefaultFolder(olFolderContacts)
  Set Items = Folder.Items
  
  If Items.Count Then
    Set Item = Items(1)
    Email1 = Item.GetIDsFromNames("{00062004-0000-0000-C000-000000000046}", &H8083) Or &H1E
    Email2 = Item.GetIDsFromNames("{00062004-0000-0000-C000-000000000046}", &H8093) Or &H1E
    Email3 = Item.GetIDsFromNames("{00062004-0000-0000-C000-000000000046}", &H80A3) Or &H1E
    
    Set Filter = Items.MAPITable.Filter
    Filter.Clear
    
    Set ResOr = Filter.SetKind(RES_OR)
    
    Set ResContent = ResOr.Add(RES_CONTENT)
    ResContent.ulPropTag = Email1
    ResContent.lpProp = FindString
    ResContent.ulFuzzyLevel = FL_IGNORECASE Or FL_SUBSTRING
    
    Set ResContent = ResOr.Add(RES_CONTENT)
    ResContent.ulPropTag = Email2
    ResContent.lpProp = FindString
    ResContent.ulFuzzyLevel = FL_IGNORECASE Or FL_SUBSTRING
    
    Set ResContent = ResOr.Add(RES_CONTENT)
    ResContent.ulPropTag = Email3
    ResContent.lpProp = FindString
    ResContent.ulFuzzyLevel = FL_IGNORECASE Or FL_SUBSTRING
    
    Filter.Restrict
    
    If Items.Count Then
      Set CollAdr = New VBA.Collection
      Index = 0
      Msg = ""
      Items.Sort "FileAs", False
      
      For Each Item In Items
        Adr = ""
        If Len(Item.Email1Address) Then
          Index = Index + 1
          Adr = Index & ": " & Item.Email1Address & vbCrLf & vbTab
          CollAdr.Add Item.Email1Address
        End If
        If Len(Item.Email2Address) Then
          Index = Index + 1
          Adr = Adr & Index & ": " & Item.Email2Address & vbCrLf & vbTab
          CollAdr.Add Item.Email2Address
        End If
        If Len(Item.Email3Address) Then
          Index = Index + 1
          Adr = Adr & Index & ": " & Item.Email3Address & vbCrLf
          CollAdr.Add Item.Email3Address
        End If
        If Len(Adr) Then
          Msg = Msg & vbCrLf & Item.FileAs & vbCrLf & vbTab & Adr
        End If
      Next
      
      If CollAdr.Count Then
        Msg = "Geben Sie die Adressziffer ein (mehrere durch Semikolon trennen):" & vbCrLf & Msg
        FindString = InputBox(Msg, Items.Count & " Kontakte mit '" & FindString & "' in einer Adresse")
        If Len(FindString) = 0 Then Exit Sub
        FindString = Replace(FindString, ",", ";")
        UseAdr = Split(FindString, ";")
        
        Msg = "Ziffer für Adresstyp eingeben:" & vbCrLf
        Msg = Msg & "1 = AN" & vbCrLf
        Msg = Msg & "2 = CC" & vbCrLf
        Msg = Msg & "3 = BCC"
        AdrType = Val(InputBox(Msg, , 1))
        If AdrType = 0 Then Exit Sub
        
        If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
          Set obj = Application.ActiveInspector.CurrentItem
          If TypeOf obj Is Outlook.MailItem Then
            Set Mail = obj
          End If
        End If
        If Mail Is Nothing Then
          Set Mail = Application.CreateItem(olMailItem)
          IsNewMail = True
        End If
        
        Adr = ""
        For i = 0 To UBound(UseAdr)
          Index = Val(UseAdr(i))
          If Index > 0 And Index <= CollAdr.Count Then
            Adr = Adr & CollAdr(Index) & "; "
          End If
        Next
        
        Select Case AdrType
        Case 2: Mail.cc = Adr
        Case 3: Mail.BCC = Adr
        Case Else: Mail.To = Adr
        End Select
        
        If IsNewMail Then
          Mail.Display
        End If
        Mail.Recipients.ResolveAll
      End If
    End If
  End If
  If Mail Is Nothing Then
    MsgBox "Der Begriff '" & FindString & "' wurde nicht gefunden", vbInformation
  End If
End Sub