Option Explicit
Public WithEvents SentItemsAdd As Outlook.Items
'Code to be applied once logon is complete
Private Sub Application_MAPILogonComplete()
'create the event handler on items being added to the Sent Items folder
Set SentItemsAdd = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail).Items
'Daily Maintenence on the Sent Items folder, mails will be moved to a subfolder by To name
'Any items whose auto delete period had been reached will be squished
scheduleSentProcesing
End Sub
Private Sub Application_Quit()
ProcessInbox
End Sub
'Run the Sent Items Processing code if this is the first time this Method is called today
Private Sub scheduleSentProcesing()
Dim sLastRun As String
sLastRun = Format(Now, "ddddd")
'Retrieve the date of the last run from the registry
If GetSetting("ProcessSentItems", "Settings", "LastRun", "") = sLastRun Then
Exit Sub
End If
ProcessSentItems
'store the last run date as today
SaveSetting "ProcessSentItems", "Settings", "LastRun", sLastRun
End Sub
'Runs every time an item is added to the Sent Items folder
Private Sub SentItemsAdd_ItemAdd(ByVal Item As Object)
'Only items marked for immediate deletion will be effected here
Call deleteItem(Item, True)
End Sub
'Delete this item if appropriate
Private Function deleteItem(Item As Object, autoDefault As Boolean) As Boolean
Dim strMonthsToKeep As String
Dim strSubject As String
Dim iSubjectLength As Integer
Dim iDeleteStartPosistion As Integer
Dim iMonthsToKeep As Integer
Dim dteSentOn As Date
Dim dteDeleteDate As Date
Dim iDaysDifferent As Integer
'The deletion indicator is at the end of the subject and will be:
' :. = Delete now
' :dn = Delete n months after sending
If Item.Subject Like "*:." Then
'Delete Now
Item.Delete
deleteItem = True
ElseIf Item.Subject Like "*:d*" Then
'get the number element from the subject, when I've added it it will be at the end and a number, anything else
'is a false find
strSubject = Item.Subject
iSubjectLength = Len(strSubject)
iDeleteStartPosistion = InStr(strSubject, ":d") + 1
strMonthsToKeep = Right(strSubject, (iSubjectLength - iDeleteStartPosistion))
On Error Resume Next
iMonthsToKeep = CInt(strMonthsToKeep)
On Error GoTo 0
If iMonthsToKeep > 0 Then
dteSentOn = Item.SentOn
dteDeleteDate = DateAdd("M", -iMonthsToKeep, Date)
iDaysDifferent = DateDiff("d", dteSentOn, dteDeleteDate)
If iDaysDifferent >= 0 Then
Item.Delete
deleteItem = True
End If
End If
ElseIf autoDefault = True Then
'an auto delete has not been set, which is naughty.
'Default it two two months
Item.Subject = Item.Subject & ":d2"
Item.Save
End If
End Function
'Trawl the Sent Items Folder, go through all items and all sub folders
'Items not in a sub folder will be moved to one
Public Sub ProcessSentItems()
Dim oSentItems As Outlook.Items
Dim oSentFolder As MAPIFolder
Dim oSentSubFolder As MAPIFolder
Dim oItem As Object
'Get instances of the Sent Items folder and the items collection in it
Set oSentFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)
Set oSentItems = oSentFolder.Items
'Delete each item or move it to a sub folder
For Each oItem In oSentItems
If deleteItem(oItem, True) = False Then
'the item wasn't marked for imediate deletion so move it to a sub folder
moveToSentTidyFolder oSentFolder, oItem
End If
Next oItem
'Check the items in each sub folder for delayed deletion
For Each oSentSubFolder In oSentFolder.Folders
tryToDeleteItemsInFolder oSentSubFolder
'remove empty folders
If oSentSubFolder.Items.Count = 0 Then
oSentSubFolder.Delete
End If
Next oSentSubFolder
Set oSentFolder = Nothing
Set oSentSubFolder = Nothing
Set oSentItems = Nothing
Set oItem = Nothing
End Sub
'Trawl the Sent Items Folder, go through all items and all sub folders
'Items not in a sub folder will be moved to one
Public Sub ProcessInbox()
Dim oInboxFolder As MAPIFolder
Dim oStorageFolder As MAPIFolder
'Get instance of the inbox folder
Set oInboxFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
tryToDeleteItemsInFolder oInboxFolder
'Get instance of the Storage folder,
'this only works because I've manually created a folder under inbox called 'store'
'where I sling mails that I'm keeping, but only for a defined anount of time
Set oStorageFolder = oInboxFolder.Folders.Item("store")
tryToDeleteItemsInFolder oStorageFolder
Set oInboxFolder = Nothing
Set oStorageFolder = Nothing
End Sub
Private Sub tryToDeleteItemsInFolder(folder As MAPIFolder)
Dim oFolderItems As Outlook.Items
Dim oItem As Object
'Get instance of the items collection in the folder
Set oFolderItems = folder.Items
'try to delete each item
For Each oItem In oFolderItems
deleteItem oItem, False
Next oItem
Set oFolderItems = Nothing
Set oItem = Nothing
End Sub
'move items in the root of a folder to a sub folder names bu the To field (or applicable alernative)
Private Sub moveToSentTidyFolder(ByRef SourceFolder As MAPIFolder, Item As Object)
Dim strFolderName As String
Dim oMoveToFolder As MAPIFolder
'Get the name of the folder to be used
strFolderName = getSentToName(Item)
'Does new folder exist?
On Error Resume Next
Set oMoveToFolder = SourceFolder.Folders(strFolderName)
On Error GoTo 0
If oMoveToFolder Is Nothing Then
Set oMoveToFolder = SourceFolder.Folders.Add(strFolderName)
End If
Item.Move oMoveToFolder
Set oMoveToFolder = Nothing
End Sub
'Decide what type of Item this is and therefore what field to use for the folder name
Private Function getSentToName(Item As Object) As String
Dim strFolderName As String
strFolderName = "Unknown Type"
Select Case True
Case TypeOf Item Is MailItem
strFolderName = Item.To
Case TypeOf Item Is MeetingItem
strFolderName = Item.SenderName
Case TypeOf Item Is AppointmentItem
strFolderName = Item.Organizer
Case TypeOf Item Is MAPIFolder
'Dont move Sub Folders
'this doesn't get hit as folders aren't in the items collection of a folder
'but if I forget in the future and call this method, passing in a folder as object
'it could get a bit messy
Exit Function
End Select
getSentToName = strFolderName
End Function
'Allows a keyboard shortcut to be set up for setting a mail item for immediate deletion
Public Sub MarkForDeletion()
Dim oItem As MailItem
Set oItem = Application.ActiveExplorer.Selection.Item(1)
DelNow oItem
Set oItem = Nothing
End Sub
Private Sub DelNow(Item As MailItem)
Item.Subject = Item.Subject & ":."
Item.Save
End Sub
'Allows a keyboard shortcut to be set up for setting a mail item for deletion in one month
Public Sub MarkForDeletion1()
Dim oItem As MailItem
Set oItem = Application.ActiveExplorer.Selection.Item(1)
Del1 oItem
Set oItem = Nothing
End Sub
Private Sub Del1(Item As MailItem)
Item.Subject = Item.Subject & ":d1"
Item.Save
End Sub
'Allows a keyboard shortcut to be set up for setting a mail item for deletion in twelve months
Public Sub MarkForDeletion12()
Dim oItem As MailItem
Set oItem = Application.ActiveExplorer.Selection.Item(1)
Del12 oItem
Set oItem = Nothing
End Sub
Private Sub Del12(Item As MailItem)
Item.Subject = Item.Subject & ":d12"
Item.Save
End Sub
'Allows a keyboard shortcut to be set up for setting a mail item for deletion in six months
Public Sub MarkForDeletion6()
Dim oItem As MailItem
Set oItem = Application.ActiveExplorer.Selection.Item(1)
Del6 oItem
Set oItem = Nothing
End Sub
Private Sub Del6(Item As MailItem)
Item.Subject = Item.Subject & ":d6"
Item.Save
End Sub
'Allows a keyboard shortcut to be set up for setting a mail item for deletion in twenty four months
Public Sub MarkForDeletion24()
Dim oItem As MailItem
Set oItem = Application.ActiveExplorer.Selection.Item(1)
Del24 oItem
Set oItem = Nothing
End Sub
Private Sub Del24(Item As MailItem)
Item.Subject = Item.Subject & ":d24"
Item.Save
End Sub
