Bulk Change Contact's FileAs Format to Match Outlook's Default Setting

This version of the Bulk Change File As Format for Contacts macro checks the registry for the user's default FileAs format and offers to change it. It then updates the contacts in the default contact folder to use the default FileAs format.

It's not the cleanest code, but it works in all versions of Outlook and gets the job done.

Public Sub ChangeFileAs()
    Dim objOL As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objContact As Outlook.ContactItem
    Dim objItems As Outlook.Items
    Dim objContactsFolder As Outlook.MAPIFolder
    Dim obj As Object
    Dim strFileAs As String
    Dim myRegKey As String
    Dim myValue As String
    Dim myFileAs As String
    Dim myAnswer As Integer
    
On Error Resume Next

  ' get registry key to work with
  ' change the Outlook version # to match your version
  myRegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Outlook\Contact\FileAsOrder"
  If myRegKey = "" Then Exit Sub
  'check if key exists
  If RegKeyExists(myRegKey) = True Then
    'key exists, read it
    myValue = RegKeyRead(myRegKey)
    If myValue = 14870 Then myFileAs = "Company"
    If myValue = 32791 Then myFileAs = "Last, First"
    If myValue = 32792 Then myFileAs = "Company (Last, First)"
    If myValue = 32793 Then myFileAs = "Last, First (Company)"
    If myValue = 32823 Then myFileAs = "First Last"
   
    
    'display result and ask if it should be changed
    myAnswer = MsgBox("The registry value for the key """ & _
               myRegKey & """is """ & myFileAs & vbCrLf & _
               "Do you want to change it?", vbYesNo)
  Else
    'key doesn't exist, ask if it should be created
    myAnswer = MsgBox("The registry key """ & myRegKey & _
               """ could not be found." & vbCr & vbCr & _
               "Do you want to create it?", vbYesNo)
  End If
  If myAnswer = vbYes Then
    'ask for new registry key value

    myValue = InputBox("Please enter new value: " & vbCrLf & _
    "14870 = Company" & vbCrLf & _
    "32791 = Last, First" & vbCrLf & _
    "32792 = Company (Last, First)" & vbCrLf & _
    "32793 = Last, First (Company)" & vbCrLf & _
    "32823 = First Last", myRegKey, myValue)
    If myValue <> "" Then
      RegKeySave myRegKey, myValue
      MsgBox "Registry key saved."
    End If    
  Else
  End If

' now that we've got the value of the default setting,
' we use it to set the value so all contacts are the same
    Set objOL = CreateObject("Outlook.Application")
    Set objNS = objOL.GetNamespace("MAPI")
    Set objContactsFolder = objNS.GetDefaultFolder(olFolderContacts)
    Set objItems = objContactsFolder.Items

    For Each obj In objItems
        'Test for contact and not distribution list
        If obj.Class = olContact Then
            Set objContact = obj

            With objContact

    If myValue = 14870 Then strFileAs = .CompanyName '"Company"
    If myValue = 32791 Then strFileAs = .LastNameAndFirstName '"Last, First"
    If myValue = 32792 Then strFileAs = .CompanyAndFullName '"Company (Last, First)"
    If myValue = 32793 Then strFileAs = .FullNameAndCompany '"Last, First (Company)"
    If myValue = 32823 Then strFileAs = .FullName '"First Last"

               .FileAs = strFileAs

                .Save
            End With
        End If

        Err.Clear
    Next

    Set objOL = Nothing
    Set objNS = Nothing
    Set obj = Nothing
    Set objContact = Nothing
    Set objItems = Nothing
    Set objContactsFolder = Nothing
End Sub

'reads the value for the registry key i_RegKey
'if the key cannot be found, the return value is ""
Function RegKeyRead(i_RegKey As String) As String
Dim myWS As Object

  On Error Resume Next
  'access Windows scripting
  Set myWS = CreateObject("WScript.Shell")
  'read key from registry
  RegKeyRead = myWS.RegRead(i_RegKey)
End Function

'sets the registry key i_RegKey to the
'value i_Value with type i_Type
'if i_Type is omitted, the value will be saved as string
'if i_RegKey wasn't found, a new registry key will be created
Sub RegKeySave(i_RegKey As String, _
               i_Value As String, _
      Optional i_Type As String = "REG_DWORD")
Dim myWS As Object

  'access Windows scripting
  Set myWS = CreateObject("WScript.Shell")
  'write registry key
  myWS.RegWrite i_RegKey, i_Value, i_Type

End Sub

'returns True if the registry key i_RegKey was found
'and False if not
Function RegKeyExists(i_RegKey As String) As Boolean
Dim myWS As Object

  On Error GoTo ErrorHandler
  'access Windows scripting
  Set myWS = CreateObject("WScript.Shell")
  'try to read the registry key
  myWS.RegRead i_RegKey
  'key was found
  RegKeyExists = True
  Exit Function
  
ErrorHandler:
  'key was not found
  RegKeyExists = False
End Function

How to use the macros on this page

First: You need to have macro security set to the lowest setting, Enable all macros during testing. The macros will not work with the top two options that disable all macros or unsigned macros. You could choose the option Notification for all macros, then accept it each time you restart Outlook, however, because it's somewhat hard to sneak macros into Outlook (unlike in Word and Excel), allowing all macros is safe, especially during the testing phase. You can sign the macro when it is finished and change the macro security to notify.

To check your macro security in Outlook 2010 and newer, go to File, Options, Trust Center and open Trust Center Settings, and change the Macro Settings. In Outlook 2007 and older, look at Tools, Macro Security.

After you test the macro and see that it works, you can either leave macro security set to low or sign the macro.

The macros on this page should be placed in a module.

Open the VBA Editor by pressing Alt+F11 on your keyboard.

To put the code in a module:

1. Right click on Project1 and choose Insert > Module
2. Copy and paste the macro into the new module.

More information as well as screenshots are at How to use the VBA Editor