Auto Delete Completed Outlook Tasks

[SaturnSeven]

I'm trying to write some vba code that on opening Outlook 2003 it automatically deletes completed tasks.
Any help will be greatly apprecicated

 

[mikej336]

Here is some rough code I thru together to delete appointments from a public Calandar. It may give you some ideas on where to get started. I got code examples from all over the web.

Application_Startup() is basically your autoexec.bat for Outlook.

Uncle Mike



Function PurgeCalendarFolder(objFolder As MAPIFolder) As String
Dim colItems As Items
Dim colOldItems As Items
Dim objItem As AppointmentItem
Dim strRes As String
Dim intCount As Integer
Dim strRestrict As String
Dim allpurged As Integer
Dim loopurged As Integer
Dim oldcount As Integer


loopurged = 1

Do While loopurged > 0

' make sure this is a Calendar folder
If objFolder.DefaultItemType = olAppointmentItem Then
Set colItems = objFolder.Items

' get all the recurrences
colItems.Sort "[Start]"
colItems.IncludeRecurrences = True

' set optional restriction
'strRestrict = GetRestrictDate(objFolder.Name)
strRestrict = "[End] < ""4/1/2000"""

'If Month(Date) < 12 Then
' strResponse = Month(Date) + 1 & "/1/" & Year(Date) - 1
'Else
' strResponse = "1/1/" & Year(Date)
'End If


Set colOldItems = colItems.Restrict(strRestrict)

' perform deletions
Set objItem = colOldItems.GetFirst
Do Until objItem Is Nothing
Debug.Print objItem.Start; objItem.End; objItem.Subject; objItem
strtext = strtext & objItem.Start & objItem.End & objItem.Subject & objItem & vbCrLf

objItem.Delete
intCount = intCount + 1
Set objItem = colOldItems.GetNext
Loop
End If

' report back to calling procedure
If intCount > 0 And intCount <> oldcount Then
strRes = Format(intCount) & " items purged"
allpurged = allpurged + intCount
oldcount = intCount
intCount = 0
Else
strRes = "no items purged"
loopurged = 0
End If

Debug.Print "**** " & strRes & " ****"
strtext = strtext & "**** " & strRes & " ****" & vbCrLf
Loop

strRes = "Total of " & Format(allpurged) & " items purged"
strtext = strtext & strRes

PurgeCalendarFolder = strRes

Set objItem = Nothing
Set colItems = Nothing
Set colOldItems = Nothing

End Function
Sub TestPurgeCalendarFolder()
Dim objOutlook As Application
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim strtext As String


Set objOutlook = CreateObject("Outlook.Application")
Set objNS = objOutlook.GetNamespace("MAPI")
'Set objFolder = objNS.PickFolder

'New code from here down
Set MyFolder1 = objNS.Folders("Public Folders")
Set MyFolder2 = MyFolder1.Folders("All Public Folders")
'Set MyFolder3 = MyFolder2.Folders("My Public Folder")
Set objFolder = MyFolder2.Folders("test")

If Not objFolder Is Nothing Then
'Debug.Print PurgeCalendarFolder(objFolder)
MsgBox PurgeCalendarFolder(objFolder)
End If

Set objFolder = Nothing
Set objNS = Nothing
Set objOutlook = Nothing
End Sub
Private Sub Application_Startup()
'MsgBox "Welcome, " & Application.GetNamespace("MAPI").CurrentUser
'Application.ActiveExplorer.WindowState = olMaximized
Call TestPurgeCalendarFolder
End Sub