Kontaktrename

Im November 2007 habe ich meine Outlook Kontakte mit einem Windows Mobile Smartphone abgeglichen und bin natürlich auf das Problem gestoßen, dass all meine Kontakte falsch geschrieben waren. Ich hatte meine Kontakte alle in der Form "Firma (Nachname, Vorname) gespeichert. Das Feld "FileAs" ist natürlich das Feld, welches das Smartphone im Telefonbuch anzeigt. Hier ist es nu natürlich überhaupt nicht sinnvoll, wenn man Aufgrund der begrenzen Displaybreite nur die Firmennamen zu lesen bekommt.

Nun wollte ich auf der anderen Seite natürlich nicht bei allen Kontakten von Hand die Benennung "umdrehen". Es hat mich aber ca. 15 Minuten gekostet, ein VBA-Makro für Outlook zu schreiben, was genau das für mich macht.

Starten Sie einfach den VBA-Editor (Alt-F11) und kopieren Sie dieses Makro hinein.

Sub ContactDisplayname()

    Dim ns As Outlook.NameSpace
    Set ns = GetNamespace("MAPI")
    
    Dim Contact As Outlook.MAPIFolder
    Set Contact = ns.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderContacts)
    Set ContactFolder = ns.PickFolder

    Dim Item As Outlook.ContactItem
    Dim newFileAs As String für Each Item In Contact.Items
        Debug.Print "ALT:" & Item.FileAs
        newFileAs = ""
        If Item.LastName <> "" Then newFileAs = newFileAs & Item.LastName
        If Item.FirstName <> "" Then
            If newFileAs <> "" Then
                newFileAs = newFileAs & ", " & Item.FirstName
            Else
                newFileAs = newFileAs & Item.FirstName
            End If
        End If
        If Item.CompanyName <> "" Then
            If newFileAs = "" Then
                newFileAs = newFileAs & "(" & Item.CompanyName & ")"
            Else
                newFileAs = newFileAs & " (" & Item.CompanyName & ")"
            End If
        End If
        Debug.Print "NEU:" & newFileAs
        Debug.Print "----------------------"
        If Item.FileAs = newFileAs Then
            Debug.Print "SKIP - already OK"
        Else
            Item.FileAs = newFileAs
            Item.Save
        End If
    Next
    
    Set ns = Nothing
    Set Contact = Nothing

End Sub

Starten können Sie das Makro einfach über die "Play"-Taste in der Taskleiste oder F5.

Weitere Links