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:
- Right click on Project1 and choose Insert > Module
- Copy and paste the macro into the new module.
More information as well as screenshots are at How to use the VBA Editor
Thank you Diane! This saved a lot of time. Appreciate you sharing it. Blessings.
Thank you Diane; that's so helpful. I had to tweak the registry address from ""HKEY_CURRENT_USER\Software\Microsoft\Office\15.0\Outlook\Contact\FileAsOrder"" to "HKEY_CURRENT_USER\Software\Microsoft\Office\12.0\Outlook\Contact\FileAsOrder"" for Outlook 2007, but that's no big deal. What gets me though is that it was necessary in the first place. Perhaps there's someone at Redmond who goes by the unfortunate name of "Smith Comma Fred", but otherwise I think you'd have to go back to 19th century London to find people in the workplace referring to each other by their surnames. So why order the contacts by surname by default? Really odd.
Me again......Trying to apply macro to new Office 365. Keep getting the error "User-defined type not defined". Beow is what is highlighted.
Public Sub ChangeFileAs()
Dim objOL As Outlook.Application
Update.....all set....
Marty
Hello,
I have used this code on my personal laptop and it worked fine. I am now trying to use it on my work laptop and I keep getting the prompt to choose a macro, but none are listed.
Any ideas?
Marty
Do you have macro security set to allow it and the macro project properly signed if using allow signed macro only?
So sorry to ask, but I forgot how to actually apply the code?
Alt+F11 to open the editor, paste the code into a module or thisoutlooksession then click Run.
This macro runs on all of the contacts in the default contacts folder.
I forgot to block it as code..... (remove my previous comment)
Your code is absolute GOLD! I had to remember how to get to the macros and create a new module tho ...haha. But it ran to perfection!.
One minor suggestion. I have about 10 contacts that are Company name only. When I chose First Name Last Name, The 10 contacts did not stay as FileAs CompanyName. They got cleared out. I'll probably modify the code but thought you might want to change it.