Move Contacts to a Folder

[LMS]

Below is the macro that moves emails to a different folder......what can we change specifically to move selected contacts to another subfolder or sub sub folder under Contacts?

Sub MoveSelectedMessagesToFolderOutlookForum()

Dim objFolder As outlook.MAPIFolder, objInbox As outlook.MAPIFolder
Dim objNS As outlook.NameSpace, ObjItem As outlook.mailItem

Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)

On Error Resume Next

Set objFolder = objInbox.Folders("Technical").Folders("Outlook Forum")

'Assume this is a mail folder

If objFolder Is Nothing Then
MsgBox "This folder doesn’t exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is selected
Exit Sub
End If

For Each ObjItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olMailItem Then
If ObjItem.Class = olMail Then
ObjItem.Move objFolder
End If
End If
Next

Set ObjItem = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing

End Sub

 

[LMS]

To All In Case This Helps:

As an example, under Contacts, I have a subfolder named "Test" and I changed the macro above and I selected a contact in another folder, and it moved it to the Test folder....so here it is again, just in case others need it for help:

Sub MoveSelectedContactsToContactsTestFolder()

Dim objFolder As outlook.MAPIFolder, objInbox As outlook.MAPIFolder
Dim objNS As outlook.NameSpace, ObjItem As outlook.contactItem

Set objNS = Application.GetNamespace("MAPI")
Set objContacts = objNS.GetDefaultFolder(olFolderContacts)

On Error Resume Next

Set objFolder = objContacts.Folders("Test")

'Assume this is a contact folder

If objFolder Is Nothing Then
MsgBox "This folder doesn’t exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a contact is selected
Exit Sub
End If

For Each ObjItem In Application.ActiveExplorer.Selection
If objFolder.DefaultItemType = olContactItem Then
If ObjItem.Class = olContact Then
ObjItem.Move objFolder
End If
End If
Next

Set ObjItem = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing

End Sub

 

[Diane Poremsky]

Correct, you need to change the item and folder type - it'll work with any outlook item type if you change the object type.

Dim ObjItem As outlook.contactItem
Set objInbox = objNS.GetDefaultFolder(olFoldercontacts)

(and yes, it looks weird to refer to the contacts as objInbox, but that's just a variable name for the folder we set using olfoldercontacts.)