I learn there is a code that you put the name of the Category, hightligh a list of Contacts and it adds the Category 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? This way I can have a macro for each Cagegory and then can create a Userform with a droplist of Categories to add where ever I want to: 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
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