Move outlook mail from one mailbox inbox to different folder in same mailbox - vba

Question

I have several mailboxes which I can see in my Outlook profile. One of the mailboxes, let's call it "Mailbox - HUR" receives messages constantly. presently one of my team goes into the inbox of this mailbox every day and moves (drag and drop) the messages into a subfolder of the inbox called Archive (we're an imaginative lot!) if the messages are greater than 24 hours old.
Is there any way that a macro can be set up to do this task? I know my simple way around VBA but have never used it with Outlook and can't figure out the namespace details to point me to the correct mailbox instead of my mailbox.
Unfortunately I do not have access to Exchange server, only using outlook client.
Any help anyone could give would be great.

Answer 1

You might like to try:
Sub MoveOldEmail()
Dim oItem As MailItem
Dim objMoveFolder As MAPIFolder
Dim objInboxFolder As MAPIFolder
Dim i As Integer
Set objMoveFolder = GetFolder("Personal Folders\Inbox\Archive")
Set objInboxFolder = GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
For i = objInboxFolder.Items.Count - 1 To 0 Step -1
With objInboxFolder.Items(i)
''Error 438 is returned when .receivedtime is not supported
On Error Resume Next
If .ReceivedTime < DateAdd("h", -24, Now) Then
If Err.Number = 0 Then
.Move objMoveFolder
Else
Err.Clear
End If
End If
End With
Next
Set objMoveFolder = Nothing
Set objInboxFolder = Nothing
End Sub
Public Function GetFolder(strFolderPath As String) As MAPIFolder
'' strFolderPath needs to be something like
'' "Public Folders\All Public Folders\Company\Sales" or
'' "Personal Folders\Inbox\My Folder"
Dim objNS As NameSpace
Dim colFolders As Folders
Dim objFolder As MAPIFolder
Dim arrFolders() As String
Dim i As Long
On Error GoTo TrapError
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objNS = GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then
Exit For
End If
Next
End If
On Error GoTo TrapError
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Exit_Proc:
Exit Function
TrapError:
MsgBox Err.Number & " " & Err.Description
End Function

Answer 2

You should setup a mailbox rule. Tools | Rules Wizard
If you are using Exchange server have an Outlook rule to move the emails to the specific folder, then use the Mailbox Manager in Exchange to delete messages from that folder after a specific period of time. See this article for more information.

Answer 3

Fionnuala you rock!
I've been looking for a solution to a similar issue for months. With my corporate restrictions, I wasn't able to use the UDF (worked just fine on my personal); Within the sub MoveOldEmail, I instead used:
Set objMoveFolder = GetNamespace("MAPI").PickFolder
Cool thing is that this seems to let me move between email accounts that I have associated with my Outlook (until corp figures out at least).