Search code examples
vbaoutlookoutlook-2010

Outlook monitor Subfolder and run Macro


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.


Solution

  • 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.