Outlook 2007 move email to sub-folder macro

Craig321 · 12 Oct 2009 at 16:39

I have the following code to move an email into a sub-folder:

Code:

Sub Archive()
On Error Resume Next
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)
Set objFolder = objInbox.Folders("Archive")

If objFolder Is Nothing Then
MsgBox "This folder doesn’t exist!", vbOKOnly + vbExclamation, "INVALID FOLDER"
End If
If Application.ActiveExplorer.Selection.Count = 0 Then

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

However, when the email is moved for some reason the date the email was received gets changed.

Is there any way to preserve the date after the file has been moved by this macro?

Thanks,
Craig.

Manlove is my forte · 12 Oct 2009 at 16:52

Is there any reason you're not using outlook rules to move the email?

Craig321 · 12 Oct 2009 at 16:56

Manlove is my forte said:
Is there any reason you're not using outlook rules to move the email?

I want to manually archive the items when they're not in use anymore. This may be as soon as they come in, or after a few weeks/months.

HungryHippos · 12 Oct 2009 at 17:31

Tried using Redemption to do this? You can do pretty much the same things but it seems to work around the security features better

http://www.dimastr.com/redemption/

Craig321 · 12 Oct 2009 at 20:57

Eulogy said:
Tried using Redemption to do this? You can do pretty much the same things but it seems to work around the security features better

http://www.dimastr.com/redemption/

Would there be any point in me using that? I really only want to move an email using a macro without it changing the date of the email.

Craig321 · 13 Oct 2009 at 10:27

Sorted with redemption

Code:

    Sub Archive()

Dim Session As Redemption.rDOSession
Dim objFolder As Redemption.RDOFolder
Dim objItem As Outlook.MailItem
Dim objItem2 As Redemption.RDOMail

Set Session = CreateObject("Redemption.RDOSession")

Session.Logon

Set objFolder = Session.GetFolderFromPath("\\Mailbox\Inbox\Archive\2009")

If Application.ActiveExplorer.Selection.Count = 0 Then
    Exit Sub
End If

For Each objItem In Application.ActiveExplorer.Selection
    Set objItem2 = Session.GetMessageFromID(objItem.EntryID, Session.Stores.DefaultStore.EntryID)
    objItem2.Move objFolder
Next

End Sub