VBA for Outlook - is this the right place?

[tjr226]

Hi all, this might not be the best place, but I've gotten other good answers so I hope you all don't mind helping out.

I'm trying to set up an Outlook macro to mark emails as a certain category, but my current macro will only do one at a time. If I select more than one, it will only change the category on the first one I selected and ignore the others. Would someone mind looking through the code and seeing if the answer to this problem is obvious?


Sub mQuote()

Dim App As New outlook.Application
Dim exp As outlook.Explorer
Dim sel As outlook.Selection

Dim cnt As Integer

Set exp = App.ActiveExplorer
Set sel = exp.Selection

For cnt = 1 To sel.Count

sel.Item(cnt).UnRead = False
sel.Item(cnt).Categories = "Quote"

Next
End Sub

 

[Richard Schollar]

Hi

You need to Save the item after you apply the category:

Sub mQuote()

Dim App As New outlook.Application
Dim exp As outlook.Explorer
Dim sel As outlook.Selection

Dim cnt As Integer

Set exp = App.ActiveExplorer
Set sel = exp.Selection

For cnt = 1 To sel.Count

sel.Item(cnt).UnRead = False
sel.Item(cnt).Categories = "Quote"
sel.Item(cnt).Save

Next
End Sub

 

[tjr226]

Thanks! This worked perfectly.

I have a follow-up question, if you don't mind me taxing your brilliance. Along with putting those triggers together, I'd love to be able to have all the tagged emails be moved programmatically to a subfolder of my Inbox, called Archive. But, I can't quite figure out the code to correctly move it all around. Mind taking a look at the added code and seeing if there's something I can fix?



Public Sub mQuote()

Dim App As New outlook.Application
Dim exp As outlook.Explorer
Dim sel As outlook.Selection

Dim cnt As Integer

Set exp = App.ActiveExplorer
Set sel = exp.Selection

For cnt = 1 To sel.Count

sel.Item(cnt).UnRead = False
sel.Item(cnt).Categories = "Quote"
sel.Item(cnt).FlagIcon = olRedFlagIcon

On Error Resume Next

Dim objFolder As outlook.MAPIFolder
Dim Folder As outlook.MAPIFolder

Dim objNS As outlook.NameSpace

Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.Folders("Archive")

sel.Item(cnt).Move objFolder

sel.Item(cnt).Save



Next
End Sub

 

[Richard Schollar]

Following worked for me:

Public Sub mQuote()

Dim App As Application
Dim exp As Explorer
Dim sel As Selection
Dim objFolder As MAPIFolder
Dim objNS As NameSpace

Dim cnt As Integer
Set App = Application
Set exp = App.ActiveExplorer
Set sel = exp.Selection

Set objNS = Application.GetNamespace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderInbox)
Set objFolder = objFolder.Folders("Archive")

For cnt = 1 To sel.Count

    sel.Item(cnt).UnRead = False
    sel.Item(cnt).Categories = "Quote"
    sel.Item(cnt).FlagIcon = olRedFlagIcon
    
    sel.Item(cnt).Move objFolder
    
    'sel.Item(cnt).Save
Next
End Sub

 

[tjr226]

That is pretty amazing. Thanks so much for helping me out, I have no idea what I was doing wrong. I'll have to go over the code and see if I can figure it out.