views:

979

answers:

3

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.

A: 

A great place to start is MSDN.

Paulo Santos
A: 

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.

James
Hi James, I tried to do this but can only see how to set a date range where it is received before a defined date, can't see how to say if mail older than...
Steve
Hi james, Sorry I was unclear and have now edited the question. Unfortunately I only have client access to the mailbox using Outlook, I cannot use Exchange server. Steve
Steve
You should take a look at this question http://stackoverflow.com/questions/1110612/permanently-delete-mailmessage-in-outlook-with-vba
James
+2  A: 

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
Remou
This worked perfectly Remou.Thanks for your help!Steve
Steve