Public Sub ChangeEmailDisplayName_Anyfolder() Dim Session As Outlook.NameSpace Dim currentExplorer As Explorer Dim Selection As Selection Dim currentItem As Object Dim folder As Outlook.folder Dim obj As Object Dim strFirstName As String Dim strLastName As String Dim strFileAs As String Set currentExplorer = Application.ActiveExplorer Set Selection = currentExplorer.Selection On Error Resume Next For Each obj In Selection Set folder = currentItem.Parent 'Test for contact and not distribution list If obj.Class = olContact Then Set objContact = obj With objContact If .Email1Address <> "" Then ' Uncomment the strFileAs line for the desired format ' Add the email address to any string using ' the following code: ' & " (" & .Email1Address & ")" ' strFileAs = .Email1Address 'Firstname Lastname (email address) format 'strFileAs = .FullName '& " (" & .Email1Address & ")" 'Lastname, Firstname format strFileAs = .LastNameAndFirstName 'Company name (email address) format ' strFileAs = .CompanyName & " (" & .Email1Address & ")" 'Comapany Firstname Lastname (email address) format 'the display name will have a leading space if 'the contact doesn't have a company name 'strFileAs = .CompanyName & " " & .FullName & " (" & .Email1Address & ")" 'File As format 'Does not support Company (Fullname) format. 'Only Company name is used in the display name 'strFileAs = .FileAs .Email1DisplayName = strFileAs .Save End If End With End If Err.Clear Next Set Session = Nothing Set currentExplorer = Nothing Set obj = Nothing Set Selection = Nothing Set currentItem = Nothing Set folder = Nothing End Sub