Public Sub LinkItemToContact()
  Dim c As VBA.Collection
  Dim obj As Object
  Dim Links As Outlook.Links
  Dim Link As Outlook.Link
  Dim Contacts As VBA.Collection
  Dim Contact As Outlook.ContactItem
  Dim i&, y&, z&
  Dim Names() As String
  Dim b$

  b = Trim$(InputBox("Kontakte:"))
  If Len(b) = 0 Then Exit Sub
  b = Replace(b, ";", ",")
  Names = Split(b, ",")

  Set Contacts = New VBA.Collection
  For i = 0 To UBound(Names)
    If Len(Names(i)) Then
      Set Contact = GetContactByName_Ex(Names(i))
      If Not Contact Is Nothing Then
        Contacts.Add Contact
      Else
        MsgBox "Could not resolve '" & Names(i) & _
          "'. Try with the email address.", vbInformation
        Exit Sub
      End If
    End If
  Next

  Set c = GetCurrentItems
  For i = 1 To c.Count
    Set obj = c(i)
    Set Links = obj.Links
    For y = 1 To Contacts.Count
      Set Contact = Contacts(y)
      If Links.Item(Contact.Subject) Is Nothing Then
        Links.Add Contact
      End If
    Next
    If obj.Saved = False Then
      obj.Save
    End If
  Next
End Sub

Private Function GetContactByName_Ex(Name$) As Outlook.ContactItem
  Dim Folder As Outlook.MAPIFolder
  Dim Items As Outlook.Items
  Dim Item As Outlook.ContactItem
  Dim FindInDefault As Boolean
  Dim Recip As Outlook.Recipient

  If Len(Name) = 0 Then Exit Function
  Set Recip = g_Ns.CreateRecipient(Name)

  If Not Recip Is Nothing Then
    If Recip.Resolve Then
      Set Item = Recip.AddressEntry.GetContact
      If Not Item Is Nothing Then
        Set GetContactByName_Ex = Item
        Exit Function
      End If
    End If
  End If
End Function

Private Function GetCurrentItems(Optional IsInspector As Boolean _
) As VBA.Collection
  Dim c As VBA.Collection
  Dim Sel As Outlook.Selection
  Dim obj As Object
  Dim i&

  Set c = New VBA.Collection

  If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
    c.Add Application.ActiveInspector.CurrentItem
  Else
    Set Sel = Application.ActiveExplorer.Selection
    If Not Sel Is Nothing Then
      For i = 1 To Sel.Count
        c.Add Sel(i)
      Next
    End If
  End If
  Set GetCurrentItems = c
End Function