Outlook Format Contact DisplayEmailAdress

 Dim app As Outlook.Application
    Set app = CreateObject("Outlook.Application")

    Dim ns As Outlook.NameSpace
    Set ns = app.GetNamespace("MAPI")
    ns.Logon

    Dim contacts As Outlook.MAPIFolder
    Set contacts = ns.GetDefaultFolder(olFolderContacts)

    Dim Item As Outlook.ContactItem
    Dim sDisplayAs As String

    For Each Item In contacts.Items

        sDisplayAs = ""

        If (Len(Item.FirstName) * Len(Item.LastName) > 0) Then
            sDisplayAs = Item.LastName + ", " + Item.FirstName
        Else
            sDisplayAs = Item.FileAs
        End If

        If Item.CompanyName = "GERMANY" Or Item.CompanyName = "UNITED KINGDOM" Or Item.CompanyName = "NETHERLANDS" Then
            sDisplayAs = sDisplayAs + " (Microsoft)"
            Item.CompanyName = "Microsoft"
        ElseIf Len(Item.CompanyName) > 0 Then
            sDisplayAs = sDisplayAs + " (" + Item.CompanyName + ")"
        End If


        If (Len(sDisplayAs) > 0) Then
            Item.Email1DisplayName = sDisplayAs
            Item.Save
        End If

    Next