Use these code samples when you want to change the background color, move the business card image from the left side or change or rearrange the fields.
The first sample applies to all contacts in the folder, while the second sample works on just the selected contacts.
Code Sample 3: Change the business card layout to match the selected contact
To use, first edit a business card so it is exactly as you want then run the macro.
To use this code, select the contact whose card you edited then run the macro to apply it to all contacts in the folder. As with Sample 2, you can use If... Then statements to apply it to specific contacts.
Public Sub CustomizeBusinessCards() Dim obj As Object Dim oFolder As Outlook.MAPIFolder Dim oContact As Outlook.ContactItem Dim oModel As Outlook.ContactItem Dim colItems As Outlook.Items Dim i As Long Dim lCount As Long Dim sXML As String Set oFolder = Application.Session.GetDefaultFolder(olFolderContacts) Set colItems = oFolder.Items Set oModel = Application.ActiveExplorer.Selection.Item(1) sXML = oModel.BusinessCardLayoutXml lCount = colItems.Count For i = 1 To lCount Set obj = colItems.Item(i) If (obj.Class = olContact) Then Set oContact = obj oContact.BusinessCardLayoutXml = sXML ' oContact.AddBusinessCardLogoPicture ("C:\image\logo.gif") oContact.Save End If Next End Sub
Code Sample 4: Change the business card layout of selected contacts
To use this code sample, after changing one contact's business card, select the contact then select the contacts you want to match the first contact's business card layout to the remaining selected contacts. For example, if you select Billy, Bob, and Mary's contacts, the layout on Billy's card is applied to Bob and Mary's contacts. Use this when you want to change the background color, move the business card image from the left side or change or rearrange the fields.
Public Sub ChangeBusinessCardXML_SelectedContacts() Dim Session As Outlook.NameSpace Dim currentExplorer As Explorer Dim Selection As Selection Dim currentItem As Object Dim folder As Outlook.folder Dim oModel As Outlook.ContactItem Dim sXML As String Dim obj As Object Set currentExplorer = Application.ActiveExplorer Set Selection = currentExplorer.Selection 'uses the xml of first item selected to set the other cards that are selected Set oModel = Application.ActiveExplorer.Selection.Item(1) sXML = oModel.BusinessCardLayoutXml 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 obj.BusinessCardLayoutXml = sXML 'obj.AddBusinessCardLogoPicture ("C:\image\logo.gif") .Save 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
If you have your own code, below are the (important) parts of the code that will allow you to get the business card layout of the selected contact item then apply it to the remaining contacts.
'dim the variables Dim oModel As Outlook.ContactItem Dim sXML As String 'use the xml of first selected item to set the other cards Set oModel = Application.ActiveExplorer.Selection.Item(1) sXML = oModel.BusinessCardLayoutXml 'apply the changes With objContact obj.BusinessCardLayoutXml = sXML .save End With
I know this is an old post, but I've used the Code Sample 4 in the past and it always worked. But now I'm getting a "Variable not defined" error message and can't get it to work:
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
Any help?
I figured it out I changed the Line to
Set oFolder = Application.ActiveExplorer.CurrentFolder
I know this is an old post, and thanks so much for your help. I have a question/problem. Although the code works for updating the default folder, it does not seems to make the changes to the Business Contacts folder. How do I choose this folder as opposed to the default? I suspect the GetDefaultFolder would be replaced with something else.
This is an old post, but alas, I needed this info today and it made me happy :)
To effect the change in the currently selected folder, instead of the default outlook contact's folder, make this small change to the macro:
Where it reads:
Set oFolder = Application.Session.GetDefaultFolder(olFolderContacts)
Replace that line with the following:
Set oFolder = Application.ActiveExplorer.CurrentFolder
Then make sure when you invoke the macro (ALT+F8) that you are in the correct folder and have the contact with the desired layout selected in that window.
Thank you sooo much. I was looking for Days for a solution. It worked perfectly!!
Thanks for the guidance.....now i have all my outlook contacts in my format...:-)