Moving Messages

Now I know there are probably a few posts about this floating around however I am having an extremely difficult time finding one that will work. I have sent the last hour looking on the internet for a solution to my problem and have gotten nothing that wants to work.

So here it is I just want to move a darn email using a macro.

Now I know there are other ways to do this however my boss has very specifically requested i patch together a macro for him (and since i like my job I am not about to be arguing about it) that does two things makes the selected email or emails marked as read and then archives them. We as a firm move emails as soon as we have read them and dealt with them or alternatively the moment they come in if they do not have to be read first, so volume wise this action will never be performed on more then 1 to 3 emails at a time.

The marking as read part I have working with no problem on one email but i am not sure how to take it from that to the nth email.
Right now I am using this to mark as read:

Set obj = Application.ActiveExplorer.Selection(1)obj.UnRead = False
obj.Save
Set obj = Nothing

Now after that point I would like to call another macro to move all the selected emails to the Archive Folder (the default one where emails go when you hit backspace or press the Archive button).

And that is it.


As a bit of a informational point here I am using Outlook 2016.

Any help would be greatly appreciated.

The default archive folder is a folder called Archive off the root folder (but it can be a user configured folder) . Assuming you have the default setup, the following should work.

Code:

---

Option Explicit

Sub ArchiveSelected()
'Graham Mayor - http://www.gmayor.com - Last updated - 12 Oct 2017
Dim olItem As Object
Dim olFolder As Outlook.Folder
Dim lngItem As Long
    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "No Items selected!", vbCritical, "Error"
        Exit Sub
    End If
    On Error Resume Next
    Set olFolder = Session.GetDefaultFolder(olFolderInbox).Parent.folders("Archive")
    'Process each selected message
    For lngItem = Application.ActiveExplorer.Selection.Count To 1 Step -1
        Set olItem = Application.ActiveExplorer.Selection(lngItem)
        olItem.UnRead = False
        olItem.Move olFolder
    Next lngItem
lbl_Exit:
    Set olItem = Nothing
    Set olFolder = Nothing
    Exit Sub
End Sub

---

Thank You!!!!!! I can't say I exactly see where I was going wrong in this but right right now that doesn't matter so much. I was ready to start beating my head against a wall in frustration yesterday so this is greatly appreciated and it works perfectly.