I'm having issues with getting some code to work. I have put it together from code I found and get an error stating the Sub or Function is not defined. I'm new to Outlook VBA and can't figure it out.
Option Explicit
Private objNS As Outlook.NameSpace
Private WithEvents objItems As Outlook.Items
Private Sub Application_Startup()
Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
'Set the folder and items to watch:
'Set objWatchFolder = objNS.GetDefaultFolder(olFolderInbox)
'Set Inbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set objWatchFolder = objNS.Inbox.Folders.Item("Zip Files")
Set objItems = objWatchFolder.Items
Set objWatchFolder = Nothing
End Sub
Private Sub objItems_ItemAdd(ByVal Item As Object)
Dim oFolder As Folder
Dim Date6months As Date
Dim ItemsOverMonths As Outlook.Items
Dim DateToCheck As String
Date6months = DateAdd("d", 0, Now())
Date6months = Format(Date6months, "mm/dd/yyyy")
Set Inbox = Application.Session.GetDefaultFolder(olFolderInbox)
Set oFolder = Inbox.Folders.Item("Zip Files")
DateToCheck = "[Received] <= """ & Date6months & """"
Set ItemsOverMonths = oFolder.Items.Restrict(DateToCheck)
For i = ItemsOverMonths.Count To 1 Step -1
ItemsOverMonths.Item(i).Delete
Next
Set ItemsOverMonths = Nothing
Set oFolder = Nothing
End Sub
If anyone can point me in the right direction that would be great.
See the Changes I made and compare it with yours
Option Explicit
Private WithEvents objItems As Outlook.Items
Private Sub Application_Startup()
Dim objNS As Outlook.NameSpace
Dim objWatchFolder As Outlook.Folder
Set objNS = Application.GetNamespace("MAPI")
Set objWatchFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("Zip Files")
Set objItems = objWatchFolder.Items
End Sub
Private Sub objItems_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
DeleteOlderThan6months Item
End If
End Sub
'https://stackoverflow.com/questions/37060954/trouble-setting-the-subfolder
Sub DeleteOlderThan6months(ByVal Item As Object)
'// Declare variables
Dim oFolder As Folder
Dim Date6months As Date
Dim ItemsOverMonths As Outlook.Items
Dim DateToCheck As String
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim oItem As Object
Dim i As Long
'// set your inbox and subfolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set oFolder = Inbox.Folders("Zip Files")
Date6months = DateAdd("d", -1, Now())
Date6months = Format(Date6months, "mm/dd/yyyy")
DateToCheck = "[Received] <= """ & Date6months & """"
Set ItemsOverMonths = oFolder.Items.Restrict(DateToCheck)
' // Loop through the Items in the folder backwards
For i = ItemsOverMonths.Count To 1 Step -1
Set oItem = ItemsOverMonths.Item(i)
If TypeOf oItem Is Outlook.MailItem Then
Debug.Print oItem.Subject
oItem.Delete
End If
Next
Set ItemsOverMonths = Nothing
Set oFolder = Nothing
End Sub
Tested on Outlook 2010.