VBA script to move deleted contacts to new folder not working

A simple sample script to create a new email works fine.

But this script doesn't

Private Sub Application_Startup()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.NameSpace
    Dim olContactsFolder As Outlook.MAPIFolder

    Set olApp = Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olContactsFolder = olNamespace.GetDefaultFolder(olFolderContacts)

    ' Hook the BeforeItemMove event of the Contacts folder
    Set g_olContactsFolder = olContactsFolder ' g_olContactsFolder should be a global variable
End Sub

Private Sub g_olContactsFolder_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean)
    ' Check if the item is being moved to the Deleted Items folder
    If MoveTo.Name = "Deleted Items" Then
        Dim olDestinationFolder As Outlook.MAPIFolder
        Dim olNamespace As Outlook.NameSpace

        Set olNamespace = Outlook.Application.GetNamespace("MAPI")

        ' Specify your custom folder for deleted contacts
        ' You might need to adjust the path based on your folder structure
        On Error Resume Next
        Set olDestinationFolder = olNamespace.Folders("Personal Folders").Folders("Deleted Contacts Archive") ' Example path
        On Error GoTo 0

        If olDestinationFolder Is Nothing Then
            ' Create the folder if it doesn't exist
            Set olDestinationFolder = olNamespace.Folders("Personal Folders").Folders.Add("Deleted Contacts Archive")
        End If

        ' Move the contact item to the custom folder
        Item.Move olDestinationFolder

        ' Cancel the default move to Deleted Items
        Cancel = True
    End If
End Sub

When I open Outlook, I get a warning that there is a script, and I OK it. When I delete a Contact, it simply goes into the deleted items folder. (I delete hundreds of emails a day, and never notice if a Contact is in the list)

I added dev mode. I saved the script. I exited and restarted Outlook. I get a warning that there is a script I OK it I delete a Contact. It goes into the Deleted items folder, not the new one.

What am I missing?

Solution

This works for me.

I created a folder "ContactsArchive" inside my Contacts folder as the destination for deleted contacts (I had problems moving the contacts to a regular folder).

All code is in the ThisOutlookSession module.

Option Explicit

Dim WithEvents g_olContactsFolder As Folder

Private Sub Application_Startup()
    Set g_olContactsFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
End Sub

Private Sub g_olContactsFolder_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean)
    Static Skip As Boolean
    
    If Skip Then Exit Sub '## exit if this was triggered by the code below
    
    If MoveTo.Name = "Deleted Items" Then
        Skip = True       '## set flag to ignore the move we're about to do...
        Item.Move g_olContactsFolder.Folders("ContactsArchive")
        Cancel = True
    End If
    Skip = False '## unset the flag
End Sub

'Return the root folder for the default store
Function DefaultRootFolder() As Folder
    Set DefaultRootFolder = Application.GetNamespace("MAPI").DefaultStore.GetRootFolder
End Function