Macro to Add Category to List of Contacts

[lms]

I learn there is a code that you put the name of the Category, hightlight a list of Contacts and it adds the Category to those contacts....but, you also have to put in the name of the folder the contacts are in......the Contact folder in this code is named "Test" and the Category name is "Test Category". So is there away to change the code so don't have use a specific folder...you can highlight contacts from any folder and then adds the Category name? So is the the code to hopefully adjust:


Sub SetCategory()
' specify contact folder
Const strContactFolder As String = "Test"
' specify category to add to each contact item in the folder
Const strCategory As String = "Test Category"
' outlook App object
Dim objOutlook As Outlook.Application
' contact folder object
Dim objContactFolder As Outlook.Folder
' contact item object
Dim objContactItem As Outlook.ContactItem
' error handler
On Error GoTo ErrorHandle:
'set outlook application object
Set objOutlook = New Outlook.Application
With objOutlook.GetNamespace("MAPI")
' confirm the operation or cancel
If MsgBox("Procedure will add the Category [" & strCategory & "] to the folder [" & _
strContactFolder & "]. Do you want to proceed?", vbYesNo) <> vbYes Then GoTo Exiting:
'set contact folder object
With .GetDefaultFolder(olFolderContacts)
Set objContactFolder = .Folders.Item(strContactFolder)
End With
' add Category to each contact item in specified folder
For Each objContactItem In objContactFolder.Items
' check if category already exists for the item
If InStr(1, objContactItem.Categories, strCategory, vbTextCompare) <= 0 Then
' add category
objContactItem.Categories = objContactItem.Categories & "," & strCategory
objContactItem.Save
End If
Next objContactItem
End With
Exiting:
On Error Resume Next
' memory clean up
Set objContactItem = Nothing
Set objContactFolder = Nothing
Set objOutlook = Nothing
Exit Sub
ErrorHandle:
' detailed error message
MsgBox Err.Description
GoTo Exiting:
End Sub

[mrojas]

You may want to consider, to make it totally dynamic, creating a form that lists all folders, and when a folder is selected, its contacts are listed.
I can't seem to upload the form and its code.

Will try again later. Got to go.

[skatonni]

Instead of


With .GetDefaultFolder(olFolderContacts)
Set objContactFolder = .Folders.Item(strContactFolder)
End With

Try

Set objContactFolder = .Pickfolder