UF Exchange Support
Outlook Macro to Move 'Sent Items' to 'Retain Permanently'
Note: You may wish to have the assistance of your tier-2 support personnel for this procedure.
Step 1:
Open Windows Explorer and navigate to C:\Program Files\Microsoft Office\Office12 (or possibly Office11).
Step 2:
Run the Program 'SelfCert.exe'
Give the certificate a name, generally the username will suffice.
Choose OK and your new certificate will be saved.
Step 3:
Start Outlook.
Step 4:
If you haven't already, under your 'Mailbox', create a folder called 'Retain Permanently' and under this folder, create another folder called 'Sent Items'
Step 5:
Press Alt+F11 to open the 'Visual Basic Editor for Outlook'
Step 6:
On the Visual Basic Editor toolbar, click Insert and select Module.
Step 7:
Copy the following code. If you want to include code that will also move all items from the Sent Items to the Retain Permanently>Sent Items, remove the comment symbols (‘) on the lines of the section after the line “’This section is commented out by default”.
Sub ToRetain()
'Outlook macro code developed by Erik Schmidt at UF Active Directory
'to move Sent Items to a permanently retained Sent Items folder.
'This is for users who need an automated way to move their sent items
'to a location that is not subject to a 365 day retention policy.
On Error Resume Next
Dim objDestSent As Outlook.MAPIFolder
Dim objDestBox As Outlook.MAPIFolder
Dim objDestRetain As Outlook.MAPIFolder
Dim objSrcSent As Outlook.MAPIFolder
Dim objSrcDel As Outlook.MAPIFolder
Dim objSrcDelSent As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objCounter, objCounter2, objItemSent, objItemDelSent
Dim objMsg1, objMsg2, objMsg3, objMsg4, objResults
objCounter = 0
objCounter2 = 0
Set objNS = Application.GetNamespace("MAPI")
Set objSrcSent = objNS.GetDefaultFolder(olFolderSentMail)
Set objSrcDel = objNS.GetDefaultFolder(olFolderDeletedItems)
Set objSrcDelSent = objSrcDel.Folders("Sent Items")
Set objDestBox = objNS.GetDefaultFolder(olFolderInbox)
Set objDestBox = objDestBox.Parent
Set objDestRetain = objDestBox.Folders("Retain Permanently")
Set objDestSent = objDestRetain.Folders("Sent Items")
objMsg1 = "If there are a large number of items in your 'Sent Items' folder,"
objMsg1 = objMsg1 & " this move may take as long as a minute and Outlook may"
objMsg1 = objMsg1 & " seem unresponsive - "
objMsg1 = objMsg1 & "please be patient and wait for the process to complete!"
objMsg2 = ""
objMsg3 = " item(s) moved from your 'Deleted Items'/'Sent Items'."
objMsg4 = "Any moved items are in 'Retain Permanently'/'Sent Items'!"
MsgBox objMsg1, vbOKOnly + vbExclamation, "Warning!"
'If 'Retain Permanently' folder does not exist, create it
If objDestRetain Is Nothing Then
objDestRetain = objDestBox.Folders.Add("Retain Permanently")
Set objDestRetain = objDestBox.Folders("Retain Permanently")
Set objDestSent = objDestRetain.Folders("Sent Items")
End If
'If 'Sent Items' folder does not exist, create it
If objDestSent Is Nothing Then
objDestSent = objDestRetain.Folders.Add("Sent Items")
Set objDestSent = objDestRetain.Folders("Sent Items")
End If
‘Move items from default 'Sent Items' to retained sent items folder
‘This section is commented out by default
‘For Each objItemSent In objSrcSent.Items
‘objItemSent.Move objDestSent
‘objCounter = objCounter + 1
‘Next
'Check to see if automated process has moved anything from sent to deleted
If objSrcDelSent Is Nothing Then
objCounter2 = ""
objMsg3 = "'Deleted Items'/'Sent Items' folder does not exist! Nothing moved!"
Else
'Move items from auto deleted sent to retained sent items folder
For Each objItemDelSent In objSrcDelSent.Items
objItemDelSent.Move objDestSent
objCounter2 = objCounter2 + 1
Next
End If
'Display results for user
If objCounter > 0 Then
objMsg2 = " item(s) moved from your 'Sent Items'."
objResults = objCounter & objMsg2 & vbCr & objCounter2 & objMsg3 & vbCr & vbCr & objMsg4
Else
objResults = objCounter2 & objMsg3 & vbCr & vbCr & objMsg4
End If
MsgBox objResults, vbOKOnly + vbExclamation, "Items Moved"
'Cleanup and close
Set objItemSent = Nothing
Set objItemDelSent = Nothing
Set objDestSent = Nothing
Set objDestBox = Nothing
Set objDestRetain = Nothing
Set objSrcSent = Nothing
Set objSrcDel = Nothing
Set objSrcDelSent = Nothing
Set objNS = Nothing
End Sub
Step 8:
Paste the code into the VB module that you created in step 5, above.
Step 9:
On the toolbar, click Tools and select Digital Signature.
Step 10:
Click the Choose button.
Step 11:
Click the certificate you created and click the OK button.
Step 12:
On the toolbar, click File and select Save Project1.
Step 13:
Close the Visual Basic Editor. On the Outlook toolbar, click Tools and select Customize
Step 14:
Click the Commands tab. Then click on Macros
Step 15:
Click and hold on 'Project1.ToRetain'. Drag this to the right side of your Outlook Toolbar (at the top of the Outlook screen where you also see File, Edit, etc)
Step 16:
Right-Click on 'Projecg1.ToRetain' and in the Name field, rename your macro to something more meaningful such as 'Retain Sent Items' and hit the Enter key.
Step 17:
Again, right-click on 'Retain Sent Items' and go to Change Button Image. Select a more appealing icon for your macro by clicking on it.
Step 18:
In the customize window (which should still be open), click the ‘Close’ button.
Step 19:
You should now be able to click on your ‘Retain Sent Items’ macro from the Outlook toolbar to move all items from ‘Sent Items’ to ‘Retain Permanently’/’Sent Items’. Depending on how many items are in your ‘Sent Items’ folder to be moved, the macro can take up to a minute or so to run. At the conclusion of the run, a popup will indicate how many items were moved by the macro.
