Move Items from deleted items to another folder

[jsharrow]

My company's e-mail policy permanently deletes all items from the
"Deleted Items" folder after 29 days, but indefinitely archives
messages that reside in all other folders. For safe-keeping, I'd like
to never have anything permanently deleted.

Thus, here is the question: is there a macro that will simply take all
items in the deleted items folder every night, and copy them to
another folder so that they will be archived rather than permanently
deleted (say, "Trash")? I have next to no VBA experience, but hope
that the fix is an easy one.

I have found other macros that do similar things, but I don't want to
have to select any messages or anything; rather, when the macro runs
(and I'd hope it can run automatically) I just went all the items in
"Deleted Items" to be copied to a folder called "Trash." That's it.

Thanks in advance for anyone that help.

 

[Guest]

You don't have to select messages. Every MAPIFolder object for a given
folder has an Items collection. You can loop through the collection to get
individual Item objects and then call Item.Move (DestinationFolder), where
the argument is another MAPIFolder object.

Use this macro as a basis for your code; it shows to how to iterate a
collection and move messages to another folder. If you don't want to pick a
folder every time, note the EntryID and StoreID values for the folder you
want to move things to and get that folder explicitly in your code using the
NameSpace.GetFolderFromID method.

You also cannot easily automate running macros, unless you define a "system"
Task in Outlook and trap the Application.Reminder event. If it's your system
task, then run your macro during that event. This still won't fire though if
Outlook isn't running. There are server-side options for running code if
Outlook isn't running but involves very advanced Exchange Server programming.

Private Sub MoveReadMailToAnotherFolder()
Dim objItems As Outlook.Items, objMessage As Outlook.MailItem
Dim objMoveToFolder As MAPIFolder, objCurrentFolder As MAPIFolder
Dim objNS As Outlook.NameSpace
Dim intX As Integer

'GET THE CURRENT FOLDER DISPLAYED IN OUTLOOK
Set objCurrentFolder = Application.ActiveExplorer.CurrentFolder
If objCurrentFolder Is Nothing Then Exit Sub

Set objNS = Application.GetNamespace("MAPI")

'PROMPT THE USER TO SELECT A MAIL FOLDER TO MOVE ALL READ MESSAGES TO
Set objMoveToFolder = objNS.PickFolder
If objMoveToFolder Is Nothing Then Exit Sub

'MAKE SURE THE SELECTED FOLDER CAN CONTAIN MAIL ITEMS
If objMoveToFolder.DefaultItemType <> olMailItem Then Exit Sub

Set objItems = objCurrentFolder.Items
For intX = objItems.Count To 1 Step -1
'MAKE SURE THE MESSAGE IS AN E-MAIL, NOT A POST, CONTACT, ETC.
If objItems.Item(intX).Class = olmail Then
Set objMessage = objItems.Item(intX)
If objMessage.UnRead = False Then
objMessage.Move objMoveToFolder
End If
End If
Next
End Sub